home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2HM40.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  83.9 KB  |  2,311 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2HM; (* Hermann Seiler, 1.7.86 / 7.5.87 / 19.12.91 / 29.5.92 *)
  2.  
  3.   (* Implementation is specific for the MOTOROLA MC68040 processor. *)
  4.  
  5.   FROM SYSTEM IMPORT
  6.      WORD, LONG, SHIFT, VAL;
  7.   FROM M2SM IMPORT
  8.      Symbol, Mark;
  9.   FROM M2DM IMPORT
  10.      ObjPtr, StrPtr, StrForm, ConstValue, PDesc,
  11.      Object, Structure, Standard,
  12.      notyp, undftyp, booltyp, chartyp,
  13.      inttyp, cardtyp, bitstyp, dbltyp, realtyp, lrltyp,
  14.      proctyp, stringtyp, addrtyp, wordtyp, bytetyp,
  15.      WordSize, MinInt, MaxInt,
  16.      rngchk, ovflchk;
  17.   FROM M2LM IMPORT
  18.      pc, maxP, maxM, PutWord, PutLong, FixLink;
  19.  
  20.  
  21.   CONST
  22.  
  23.      (* Register usage and dedicated registers :   *)
  24.      (* D-Register pool for expression evaluation. *)
  25.  
  26. (*   D0  = 0;   (* freely used, never reserved *)
  27.      D1  = 1;   (* freely used, never reserved *)  *)
  28.      D2  = 2;   (* D-pool, reserved when used  *)
  29.      D3  = 3;   (* D-pool, reserved when used  *)
  30.      D4  = 4;   (* D-pool, reserved when used  *)
  31.      D5  = 5;   (* D-pool, reserved when used  *)
  32.      D6  = 6;   (* D-pool, reserved when used  *)
  33.      D7  = 7;   (* D-pool, reserved when used  *)
  34.  
  35.      (* F-Register pool for floating point arith.  *)
  36.  
  37. (*   F0  = 0;   (* freely used, never reserved *)
  38.      F1  = 1;   (* freely used, never reserved *)  *)
  39.      F2  = 2;   (* F2 - F7 reserved when used  *)
  40.      F7  = 7;
  41.  
  42.      (* A-Register pool for address calculations.  *)
  43.  
  44.      A0  = 0;   (* A-pool, reserved when used  *)
  45.      A1  = 1;   (* A-pool, reserved when used  *)
  46.      A2  = 2;   (* A-pool, reserved when used  *)
  47.      A3  = 3;   (* A-pool, reserved when used  *)
  48.  
  49. (*
  50.      (* Dedicated A-Registers. *)
  51.  
  52.      SB  = 4;   (* SB = A4 : static base pointer   *)
  53.      A5  = 5;   (* A5 is   n e v e r   used !      *)
  54.      MP  = 6;   (* MP = A6 : procedure mark        *)
  55.      SP  = 7;   (* SP = A7 : active stack pointer  *)
  56.  
  57.      (* Instruction size for simple types. *)
  58.  
  59.      byte  =  0;  word  =  1;  long  =  2;
  60.  
  61.      (* Descriptor size dynamic array parameters.  *)
  62.  
  63.      DynArrDesSize = 6;
  64. *)
  65.  
  66.      (* Addressing Mode Categories. *)
  67.  
  68.      DDIR     = 0;       (* D-Reg. direct  *)
  69.      ADIR     = 10B;     (* A-Reg. direct  *)
  70.      AIDR     = 20B;     (*     (An)       *)
  71.      AINC     = 30B;     (*     (An)+      *)
  72.      ADEC     = 40B;     (*    -(An)       *)
  73.      AOFF     = 50B;     (*  d16(An)       *)
  74.      AIDX     = 60B;     (*   d8(An,Rx)    *)
  75.      XXXW     = 70B;     (* absolute short *)
  76.      XXXL     = 71B;     (* absolute long  *)
  77.      PREL     = 72B;     (*  d16(PC)       *)
  78.      IMM      = 74B;     (* immediate or SR*)
  79.  
  80.  
  81.      (* MC68000 instruction mnemonics. *)
  82.      (* _____________________________  *)
  83.  
  84.      (* Special purpose. *)
  85.      UNLK     = 047136B; (* UNLK MP *)
  86.      LINK     = 047126B; (* LINK MP,#d16 *)
  87.      LEASP    = 047757B; (* LEA d16(SP),SP *)
  88.      INCSP    = 050217B; (* ADDQ.L #n,SP *)
  89.      DECSP    = 050617B; (* SUBQ.L #n,SP *)
  90.      MOVEMDEC = 044347B; (* MOVEM.L registers,-(SP) *)
  91.      MOVEMINC = 046337B; (* MOVEM.L (SP)+,registers *)
  92.      MVEMSP   = 027400B; (* MOVE.L  ea,-(SP) : push *)
  93.      MVESPP   = 020037B; (* MOVE.L  (SP)+,ea : pop  *)
  94.      PUSHSB   = 027410B + SB;       (* MOVE.L  SB,-(SP) *)
  95.      POPSB    = 020137B + SB*1000B; (* MOVEA.L (SP)+,SB *)
  96.  
  97.      (* Instructions without operand. *)
  98.      NOP  = 047161B; RTE  = 047163B;
  99.      RTS  = 047165B; RTD  = 047164B; (* MC68010 *)
  100.      TRAPV= 047166B; ILL  = 045374B;
  101.  
  102.      (* Branches : with a displacement. *)
  103.      BRA  = 060000B; BSR  = 060400B;
  104.      BHI  = 061000B; BLS  = 061400B; BCC  = 062000B; BCS  = 062400B;
  105.      BNE  = 063000B; BEQ  = 063400B; BVC  = 064000B; BVS  = 064400B;
  106.      BPL  = 065000B; BMI  = 065400B; BGE  = 066000B; BLT  = 066400B;
  107.      BGT  = 067000B; BLE  = 067400B;
  108.  
  109.      (* Branches : a register and a displacement. *)
  110.      DBT  = 050310B; DBRA = 050710B;
  111.      DBHI = 051310B; DBLS = 051710B; DBCC = 052310B; DBCS = 052710B;
  112.      DBNE = 053310B; DBEQ = 053710B; DBVC = 054310B; DBVS = 054710B;
  113.      DBPL = 055310B; DBMI = 055710B; DBGE = 056310B; DBLT = 056710B;
  114.      DBGT = 057310B; DBLE = 057710B;
  115.  
  116.      (* Set according to condition an effective address. *)
  117.      ST   = 050300B;
  118.  
  119.      (* Operand is a specific register. *)
  120.      SWAP = 044100B;
  121.      EXTW = 044200B; (* EXT.W byte to word *)
  122.      EXTL = 044300B; (* EXT.L word to long *)
  123.  
  124.      (* Operand is an effective address. *)
  125.      CLR  = 041000B; NEG  = 042000B;
  126.      TST  = 045000B; COM  = 043000B; (* synonym for NOT *)
  127.      JMP  = 047300B; JSR  = 047200B;
  128.      PEA  = 044100B; TAS  = 045300B;
  129.      INC1 = 051000B; (* ADDQ #1,ea *)
  130.      DEC1 = 051400B; (* SUBQ #1,ea *)
  131.  
  132.      (* Operand is an immediate value. *)
  133.      TRAP = 047100B; (* TRAP #vector *)
  134.      EMUF = 170000B; (* Line F *)
  135.      EMUA = 120000B; (* Line A *)
  136.  
  137.      (* Operands are a register and an effective address. *)
  138.      ADD  = 150000B; SUB  = 110000B;
  139.      CMP  = 130000B; EORL = 130400B; (* synonym for exclusive OR *)
  140.      ANDL = 140000B; (* synonym for AND *)
  141.      ORL  = 100000B; (* synonym for inclusive OR *)
  142.      CHK  = 040600B; LEA  = 040700B;
  143.      DIVS = 100700B; DIVU = 100300B;
  144.      MULS = 140700B; MULU = 140300B;
  145.      ADDAW= 150300B; (* ADDA.W ea,An *)
  146.      ADDAL= 150700B; (* ADDA.L ea,An *)
  147.      CMPAL= 130700B; (* CMPA.L ea,An *)
  148.      SUBAL= 110700B; (* SUBA.L ea,An *)
  149.      EXGL = 140500B; (* EXG.L  Dn,Dm *)
  150.  
  151.      (* Immediate data within op. and an effective address. *)
  152.      ADDQ = 050000B; SUBQ = 050400B;
  153.  
  154.      (* Shift register by count. *)
  155.      ASL  = 160400B; ASR  = 160000B; LSL  = 160410B; LSR  = 160010B;
  156.      ROL  = 160430B; ROR  = 160030B;
  157.  
  158.      (* Immediate data within extension and an effective address. *)
  159.      ADDI = 003000B; ANDI = 001000B; CMPI = 006000B;
  160.      EORI = 005000B; ORI  = 000000B; SUBI = 002000B;
  161.  
  162.      (* Bit manipulation. *)
  163.      BTST = 000400B; BCHG = 000500B; BCLR = 000600B; BSET = 000700B;
  164.  
  165.      (* Move groups. *)
  166.      MOVEB     = 010000B; (* group 1 *)
  167.      MOVEW     = 030000B; (* group 3 *)
  168.      MOVEL     = 020000B; (* group 2 *)
  169.      MOVEAW    = 030100B; (* MOVEA.W ea,An *)
  170.      MOVEAL    = 020100B; (* MOVEA.L ea,An *)
  171.      MOVEQ     = 070000B; (* MOVE.L #imm,Dn *)
  172.      MOVEFRCCR = 041300B; (* MOVE.W CCR,ea *)
  173.      MOVETOCCR = 042300B; (* MOVE.W ea,CCR *)
  174.  
  175.      (* MC68040 instruction supplement for integer unit. *)
  176.      CHKL      = 040400B; (* CHK long *)
  177.      DIVL      = 046100B; (* 32/32  -->  32r:32q *)
  178.      EXTBL     = 044700B; (* extend byte to long *)
  179.      MULL      = 046000B; (* 32*32  -->  32 *)
  180.      TRAPEQ    = 053774B; (* TRAP on EQ *)
  181.  
  182.      (* MC68040 instruction supplement for floating-point unit. *)
  183.      FGEN      = 171000B; (* general operation *)
  184.      FTRAPcc   = 171174B; (* no operand following *)
  185.      FST       = 171100B; (* FScc *)
  186.      FBRA      = 171200B; (* FBcc, size = word *)
  187.      FMOVEMDEC = 171047B; (* FMOVEM regs,-(SP) *)
  188.      FMOVEMD2  = 160000B; (* static list, predecrement  *)
  189.      FMOVEMINC = 171037B; (* FMOVEM (SP)+,regs *)
  190.      FMOVEMI2  = 150000B; (* static list, postincrement *)
  191.      FMOVEtoCR = 110000B; (* op-code/op-class for FMOVE to FPCR *)
  192.  
  193.      (* MC68040 instruction op-classes. *)
  194.      FtoF      = 0;       (* FPm  to FPn  *)
  195.      EAtoF     = 40000B;  (* <ea> to FPn  *)
  196.      FtoEA     = 60000B;  (* FPn  to <ea> *)
  197.      EAtoCR    = 110000B; (* <ea> to FPCR *)
  198.      CRtoEA    = 130000B; (* FPCR to <ea> *)
  199.  
  200.      (* MC68040 floating point operation codes. *)
  201.      FMOVE     = 0;     FABS      = 18H;   FNEG      = 1AH;   FSQRT     = 04H;
  202.      FADD      = 22H;   FSUB      = 28H;   FMUL      = 23H;   FDIV      = 20H;
  203.      FTST      = 3AH;   FCMP      = 38H;
  204.  
  205.      (* concerning the STATUS register. *)
  206.      NBIT      = 8;       (* negative bit *)
  207.      ZBIT      = 4;       (* zero bit *)
  208.      VBIT      = 2;       (* overflow bit *)
  209.      CBIT      = 1;       (* carry bit *)
  210.  
  211.      (* Left shift constants. *)
  212.      LS3  =  10B;  LS4  =  20B;  LS5  =  40B;   LS6  =  100B;
  213.      LS7  = 200B;  LS8  = 400B;  LS9  =  1000B; LS10 =  2000B;
  214.      LS11 = 4000B; LS12 = 10000B;
  215.  
  216.      (* System procedure numbers used by the compiler : *)
  217.      BodyOfSystem        = 0; (* 0 is reserved for module body *)
  218.      HALTX               = 1; (* System.HALTX = HALT-statement *)
  219.  
  220.  
  221.   VAR
  222.  
  223.      Rpool, Rbusy, Rlock : BITSET;
  224.      FRpool, FRbusy      : BITSET;
  225.      MoveCode            : ARRAY WidType OF CARDINAL;
  226.      ShiCode             : ARRAY [ Asl .. Ror ] OF CARDINAL;
  227.      mask                : ARRAY [ 0 .. 32 ] OF LONGINT;
  228.      hightyp             : StrPtr;
  229.  
  230.   PROCEDURE ProcessorID(VAR id: Processor);
  231.   BEGIN
  232.     id := "MC68040"
  233.   END ProcessorID;
  234.  
  235.   PROCEDURE err(n : CARDINAL);
  236.     (* local synonym for M2SM.Mark to save space! *)
  237.   BEGIN
  238.     Mark(n);
  239.   END err;
  240.  
  241.   PROCEDURE Put16(w : WORD);
  242.     (* local synonym for M2LM.PutWord to save space! *)
  243.   BEGIN
  244.     PutWord(w);
  245.   END Put16;
  246.  
  247.   PROCEDURE Put32(l : LONGINT);
  248.     (* local synonym for M2LM.PutLong to save space! *)
  249.   BEGIN
  250.     PutLong(l);
  251.   END Put32;
  252.  
  253.   PROCEDURE SignedT(VAR x : Item) : BOOLEAN;
  254.     (*      is x a signed type ?       *)
  255.     (* Note :  Real/LongReal excluded! *)
  256.     VAR s : StrPtr;
  257.   BEGIN
  258.     s := x.typ; (* let x.typ unchanged *)
  259.     IF s^.form = Range THEN s := s^.RBaseTyp END;
  260.     RETURN (s = inttyp) OR (s = dbltyp)
  261.   END SignedT;
  262.  
  263.   PROCEDURE SimpleT(VAR x : Item) : BOOLEAN;
  264.     (*   is x a simple type of size   *)
  265.     (*         byte/word/long ?       *)
  266.     (* Note : Real/LongReal excluded! *)
  267.     VAR f : StrForm; s : StrPtr; sz : CARDINAL;
  268.   BEGIN
  269.     s := x.typ; (* let x.typ unchanged *)
  270.     IF s^.form = Range THEN s := s^.RBaseTyp END;
  271.     f := s^.form; sz := VAL(CARDINAL,s^.size);
  272.     RETURN (sz IN {1,2,4}) AND ((f <= Double) OR (f = Pointer) OR
  273.             (f = Set) OR (f = ProcTyp) OR (f = Opaque))
  274.   END SimpleT;
  275.  
  276.   PROCEDURE RealT(VAR x : Item) : BOOLEAN;
  277.     (*  is x a floating-point-type ?  *)
  278.     (*       (REAL or LONGREAL)       *)
  279.     (* Note: floating-point-types are *)
  280.     (*       NOT considered as simple *)
  281.     VAR s : StrPtr;
  282.   BEGIN
  283.     s := x.typ; (* let x.typ unchanged *)
  284.     RETURN (s = realtyp) OR (s = lrltyp)
  285.   END RealT;
  286.  
  287.   PROCEDURE SimpleC(VAR x : Item) : BOOLEAN;
  288.     (* is x a simple constant of size *)
  289.     (*         byte/word/long ?       *)
  290.     (* Note : Real/LongReal excluded! *)
  291.   BEGIN
  292.     RETURN (x.mode = conMd) & SimpleT(x)
  293.   END SimpleC;
  294.  
  295.   PROCEDURE LongVal(VAR x : Item) : LONGINT;
  296.     VAR r : LONGINT;
  297.   BEGIN r := 0D;
  298.     WITH x DO
  299.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  300.       CASE typ^.form OF
  301.         Undef :        IF typ^.size = 1 THEN r := LONG(val.Ch)
  302.                        ELSIF typ^.size = 2 THEN r := LONG(val.C)
  303.                        ELSE r := val.U END;
  304.       | Bool :         r := LONG(val.B);
  305.       | Char :         r := LONG(val.Ch);
  306.       | Card, CardInt: r := LONG(val.C);
  307.       | Int :          r := LONG(val.I);
  308.       | Enum :         r := LONG(val.Ch);
  309.       | Set :          r := VAL(LONGINT, val.S);
  310.       | LCard,Double : r := val.D;
  311.       | Real :         r := VAL(LONGINT, val.R);
  312.       ELSE             r := val.D; (* String, etc. *)
  313.       END;
  314.     END (*WITH*);
  315.     RETURN r
  316.   END LongVal;
  317.  
  318.   PROCEDURE WordVal(VAR x : Item) : INTEGER;
  319.     VAR r : INTEGER;
  320.   BEGIN r := 0;
  321.     WITH x DO
  322.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  323.       CASE typ^.form OF
  324.         Undef :        IF typ^.size = 1 THEN r := ORD(val.Ch)
  325.                        ELSIF typ^.size=2 THEN r := VAL(INTEGER,val.C)
  326.                        ELSE r := VAL(INTEGER, val.U) END;
  327.       | Bool :         r := ORD(val.B);
  328.       | Char :         r := ORD(val.Ch);
  329.       | Card, CardInt: r := VAL(INTEGER, val.C);
  330.       | Int :          r := val.I;
  331.       | Enum :         r := ORD(val.Ch);
  332.       | Set :          r := VAL(INTEGER, val.S);
  333.       | LCard,Double : r := VAL(INTEGER, val.D);
  334.       | Real :         r := VAL(INTEGER, VAL(LONGINT, val.R));
  335.       ELSE             r := VAL(INTEGER, val.D); (* String, etc. *)
  336.       END;
  337.     END (*WITH*);
  338.     RETURN r
  339.   END WordVal;
  340.  
  341.   PROCEDURE ZeroVal(VAR x : Item) : BOOLEAN;
  342.     VAR b : BOOLEAN;
  343.   BEGIN b := FALSE;
  344.     IF x.mode = conMd THEN
  345.       IF    x.typ = realtyp THEN b := x.val.R = FLOAT(0)
  346.       ELSIF x.typ = lrltyp  THEN b := x.val.X = FLOATD(0)
  347.       END;
  348.     END;
  349.     RETURN b
  350.   END ZeroVal;
  351.  
  352.   PROCEDURE Iea(fea : CARDINAL) : CARDINAL;
  353.     (* invert the 'mode/register' effective address *)
  354.     (* to 'register/mode' representation.           *)
  355.   BEGIN
  356.     RETURN (fea MOD 8)*8 + (fea DIV 8)
  357.   END Iea;
  358.  
  359.   PROCEDURE Isz(VAR x : Item; VAR fsz : WidType);
  360.     (* instruction size for item x : byte/word/long. *)
  361.     (* Note :  callable only for simple types !      *)
  362.     VAR s : INTEGER; sz : WidType;
  363.   BEGIN
  364.     s := x.typ^.size;
  365.     IF    s = 1 THEN sz := byte
  366.     ELSIF s = 2 THEN sz := word
  367.     ELSIF s = 4 THEN sz := long
  368.     ELSE sz := long; err(238); (* invalid instruction size *)
  369.     END;
  370.     fsz := sz
  371.   END Isz;
  372.  
  373.   PROCEDURE SetglbMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
  374.     (* setup of an item designating a global variable *)
  375.   BEGIN
  376.     WITH x DO
  377.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  378.       mode := RindMd;  mod := 0;   lev   := 0;
  379.       adr  := fadr;    off := 0;   indir := FALSE;
  380.       R    := SB + 8;
  381.     END (*WITH*);
  382.   END SetglbMd;
  383.  
  384.   PROCEDURE SetlocMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
  385.     (* setup of an item which is relative to the Marker MP *)
  386.   BEGIN
  387.     WITH x DO
  388.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  389.       mode := RindMd;  mod := 0;   lev   := curLev;
  390.       adr  := fadr;    off := 0;   indir := FALSE;
  391.       R    := MP + 8;
  392.     END (*WITH*);
  393.   END SetlocMd;
  394.  
  395.   PROCEDURE SetregMd(VAR x : Item; freg : Register; ftyp : StrPtr);
  396.     (* setup of an item designating a (long) register. *)
  397.   BEGIN
  398.     WITH x DO
  399.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  400.       IF freg <= D7  THEN mode := DregMd ELSE mode := AregMd END;
  401.       mod := 0;     lev := curLev;
  402.       adr := 0;     off := 0;    indir := FALSE;
  403.       R   := freg;  wid := long;
  404.     END (*WITH*);
  405.   END SetregMd;
  406.  
  407.   PROCEDURE SetstkMd(VAR x : Item; ftyp : StrPtr);
  408.     (* setup of an item on top of stack. *)
  409.   BEGIN
  410.     WITH x DO
  411.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  412.       mode := stkMd;  mod := 0;   lev   := curLev;
  413.       adr  := 0;      off := 0;   indir := FALSE;
  414.       R    := SP + 8;
  415.     END (*WITH*);
  416.   END SetstkMd;
  417.  
  418.   PROCEDURE SetfltMd(VAR x : Item; fR : Register; ftyp : StrPtr);
  419.     (* setup of an item designating a floating-point register. *)
  420.   BEGIN
  421.     WITH x DO
  422.       mode := fltMd; FR := fR; typ := ftyp;
  423.     END (*WITH*);
  424.   END SetfltMd;
  425.  
  426.   PROCEDURE SetconMd(VAR x : Item; fval : LONGINT; ftyp : StrPtr);
  427.     VAR v : ConstValue;
  428.   BEGIN
  429.     WITH x DO
  430.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  431.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  432.       mode  := conMd;
  433.      CASE typ^.form OF
  434.         Undef :    IF typ^.size = 1 THEN v.Ch := VAL(CHAR, fval)
  435.                    ELSIF typ^.size = 2 THEN v.C := VAL(CARDINAL, fval)
  436.                    ELSE v.U  := fval END;
  437.       | Bool :     v.B  := VAL(BOOLEAN, fval);
  438.       | Char :     v.Ch := VAL(CHAR, fval);
  439.       | Card,
  440.         CardInt :  v.C  := VAL(CARDINAL, fval);
  441.       | Int :      v.I  := VAL(INTEGER, fval);
  442.       | Enum :     v.Ch := VAL(CHAR, fval);
  443.       | LCard :    v.D  := fval;
  444.       | Double :   v.D  := fval;
  445.       | Real :     v.R  := VAL(REAL, fval);
  446.       | Set :      v.S  := VAL(BITSET, fval);
  447.       ELSE         v.D  := fval; (* String, etc. *)
  448.       END;
  449.       val := v;
  450.     END (*WITH*);
  451.   END SetconMd;
  452.  
  453.   PROCEDURE SetbusyReg(r : Register);
  454.   BEGIN
  455.     IF r IN Rpool THEN INCL(Rbusy,r) END;
  456.   END SetbusyReg;
  457.  
  458.   PROCEDURE SetbusyFReg(r : Register);
  459.   BEGIN
  460.     IF r IN FRpool THEN INCL(FRbusy,r) END;
  461.   END SetbusyFReg;
  462.  
  463.   PROCEDURE SaveRegs(VAR save : LONGINT);
  464.     (* save the busy registers and return the list *)
  465.     (* of the saved registers in 'save'.           *)
  466.     (*                                             *)
  467.     (* Note : the saved registers are NOT released *)
  468.     (* ----   and remain busy !                    *)
  469.     (*        SP is never saved nor restored !     *)
  470.     (*                                             *)
  471.     VAR r, lr : Register; x, reglist, n : CARDINAL;
  472.         regs  : RECORD
  473.                   CASE :BOOLEAN OF
  474.                      TRUE : All : LONGINT
  475.                    | FALSE: FPU, CPU : CARDINAL
  476.                   END
  477.                 END;
  478.   BEGIN regs.All := 0D;
  479.     (* the global (CPU) registers : *)
  480.     x := 1; reglist := 0; r := SP + 8; n := 0;
  481.     REPEAT (* from SP-1 downto D0 *)
  482.       DEC(r); x := x + x;
  483.       IF (r IN Rpool) & (r IN Rbusy) THEN
  484.         INC(n); lr := r;
  485.         reglist := reglist + x;
  486.       END;
  487.     UNTIL r = D0;
  488.     IF reglist <> 0 THEN
  489.       IF n = 1 THEN Put16(MVEMSP + lr)
  490.       ELSE Put16(MOVEMDEC); Put16(reglist) END; cond
  491.   END InvertCC;
  492.  
  493.   PROCEDURE Jf(cond : Condition; VAR l : CARDINAL);
  494.     (* jump forward, build chain. *)
  495.     VAR c : CARDINAL;
  496.   BEGIN c := ORD(cond);
  497.     IF c < 16 THEN
  498.       (* MC68000 does NOT have a 'Branch on Never True' ! *)
  499.       IF c = 1 THEN Put16(CMPI) ELSE Put16(BRA + c*LS8) END;
  500.       Put16(l);
  501.     ELSE
  502.       (* MC68040's FNOP is equal to 'Branch on Never True' ! *)
  503.       Put16(FBRA + c); (* use Non-Aware Test *)
  504.       Put16(l);
  505.     END;
  506.     l := pc - 2; (* location of word-displacement *)
  507.   END Jf;
  508.  
  509.   PROCEDURE Jb(cond : Condition; l : CARDINAL);
  510.     (* jump backward, no chain. *)
  511.     VAR c, dd : CARDINAL; d : INTEGER;
  512.   BEGIN c := ORD(cond);
  513.     d  := VAL(INTEGER,l) - VAL(INTEGER,pc) - 2;
  514.     dd := VAL(CARDINAL,d);
  515.     IF (d >= -128) & (c <> 1) & (c < 16) THEN (* short branch *)
  516.       Put16(BRA + c*LS8 + (dd MOD 256))
  517.     ELSE
  518.       Jf(cond,dd)
  519.     END;
  520.   END Jb;
  521.  
  522.   PROCEDURE Scc(cond : Condition; Dn : Register);
  523.     (* set D-Register according to condition. *)
  524.     VAR c : CARDINAL;
  525.   BEGIN c := ORD(cond);
  526.     IF c < 16 THEN
  527.       Put16(ST + c*LS8 + DDIR + Dn);
  528.     ELSE
  529.       Put16(FST + DDIR + Dn);
  530.       Put16(c); (* use Non-Aware Test *)
  531.     END;
  532.     Put16(NEG + byte*LS6 + DDIR + Dn);
  533.   END Scc;
  534.  
  535.   PROCEDURE LoadCC(VAR x : Item);
  536.     (* convert from 'cocMd' to 'DregMd' while *)
  537.     (* generating conditional code.           *)
  538.     VAR Dn : Register;
  539.   BEGIN
  540.     WITH x DO
  541.       GetReg(Dn,Dreg);
  542.       IF (Tjmp = 0) & (Fjmp = 0) THEN
  543.         Scc(InvertCC(CC), Dn);
  544.         (* transform 'cocMd' to 'DregMd' *)
  545.         SetregMd(x, Dn, booltyp);
  546.         wid := byte;
  547.       ELSE
  548.         Jf(CC, Fjmp);
  549.         FixLink(Tjmp);
  550.         Put16(MOVEQ + Dn*LS9 + 1);
  551.         Put16(BRA + 2);
  552.         FixLink(Fjmp);
  553.         Put16(MOVEQ + Dn*LS9 + 0);
  554.         (* transform 'cocMd' to 'DregMd' *)
  555.         SetregMd(x, Dn, booltyp);
  556.         wid := long;
  557.       END;
  558.     END (*WITH*);
  559.   END LoadCC;
  560.  
  561.   PROCEDURE ExternalCall(mno, pno : CARDINAL);
  562.     (* call of the external procedure #pno in module #mno. *)
  563.     VAR An : Register;
  564.   BEGIN
  565.     GetReg(An,Areg); (* An IN { 8 .. 15 } *)
  566.     An := An MOD 8;
  567.     Put16(MOVEAL + An*LS9 + AOFF + SB);   (* MOVEA.L (maxP+mno)*4(SB),An *)
  568.     Put16((maxP + mno)*4);
  569.     IF pno = 0 THEN
  570.       Put16(MOVEAL + An*LS9 + AIDR + An); (* MOVEA.L (An),An      *)
  571.     ELSE
  572.       Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L pno*4(An),An *)
  573.       Put16(pno*4);
  574.     END;
  575.     Put16(JSR + AIDR + An);               (* JSR (An) *)
  576.     ReleaseReg(An + 8);
  577.   END ExternalCall;
  578.  
  579.   PROCEDURE downlevel(VAR x : Item);
  580.     (* for level difference >= 1. *)
  581.     CONST offSL = 8; (* offset of Static Link *)
  582.     VAR   N,An : Register; n : CARDINAL;
  583.   BEGIN
  584.     GetReg(N,Areg);    (* N IN { 8..15 } *)
  585.     An := N MOD 8;
  586.     Put16(MOVEAL + An*LS9 + AOFF + MP);   (* MOVEA.L offSL(MP),An *)
  587.     Put16(offSL);
  588.     n := curLev - x.lev;
  589.     WHILE n > 1 DO
  590.       DEC(n);
  591.       Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L offSL(An),An *)
  592.       Put16(offSL);
  593.     END;
  594.     ReleaseReg(x.R);
  595.     x.R := N;
  596.   END downlevel;
  597.  
  598.   PROCEDURE Ext(VAR x : Item);
  599.     (* effective address extension of x. *)
  600.     VAR ext : CARDINAL; sz : INTEGER;
  601.   BEGIN
  602.     WITH x DO
  603.       CASE mode OF
  604.         absMd :          Put32(adr);
  605.       | RindMd :         IF adr <> 0 THEN Put16(adr) END;
  606.       | RidxMd :         IF wid = word THEN ext := RX*LS12 + scl*LS9
  607.                          ELSE ext := RX*LS12 + LS11 + scl*LS9 END;
  608.                          Put16(ext + (VAL(CARDINAL,adr) MOD 256));
  609.       | conMd :          IF typ = stringtyp THEN
  610.                            Put16(val.D0 + VAL(INTEGER, maxP+maxM)*4)
  611.                          ELSE sz := typ^.size;
  612.                            IF    sz = 1 THEN Put16(WordVal(x))
  613.                            ELSIF sz = 2 THEN Put16(WordVal(x))
  614.                            ELSIF sz = 4 THEN Put32(LongVal(x))
  615.                            ELSIF sz = 8 THEN
  616.                              Put16(val.D0); Put16(val.D1);
  617.                              Put16(val.D2); Put16(val.D3);
  618.                            END;
  619.                          END;
  620.       | stkMd :          (* no extension *)
  621.       | AregMd,DregMd :  (* no extension *)
  622.       | procMd :         IF (proc <> NIL) & (proc^.pd <> NIL) &
  623.                             (proc^.pd^.adr <> 0) THEN
  624.                            (* local procedure *)
  625.                            Put16(proc^.pd^.adr - VAL(INTEGER,pc));
  626.                          ELSE (* external procedure *)
  627.                            (* no extension *)
  628.                          END;
  629.       | prgMd :          Put16(VAL(INTEGER,where) - VAL(INTEGER,pc));
  630.       | typMd,codMd :    (* no extension *)
  631.       | cocMd,fltMd :    (* no extension *)
  632.       END (*CASE*);
  633.     END (*WITH*);
  634.   END Ext;
  635.  
  636.   PROCEDURE ReduceIndir(VAR x : Item; ea : CARDINAL);
  637.     (* Note : A-Registers internally numbered from 8 .. 15! *)
  638.     VAR src, dst : Register;
  639.   BEGIN
  640.     WITH x DO
  641.       CASE mode OF
  642.         absMd :
  643.           GetReg(dst,Areg);
  644.           Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
  645.           Ext(x);
  646.       | RindMd,RidxMd :
  647.           src := R;
  648.           IF Islocked(src) THEN GetReg(dst,Areg)
  649.           ELSE dst := src END;
  650.           Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
  651.           Ext(x);
  652.           IF dst <> src THEN ReleaseReg(src) END;
  653.           IF mode = RidxMd THEN ReleaseReg(RX) END;
  654.       END (*CASE*);
  655.       (* transform all modes to 'RindMd' *)
  656.       mode := RindMd; R := dst; (* R IN { 8..15 } *)
  657.       indir := FALSE; adr := off; off := 0;
  658.     END (*WITH*);
  659.   END ReduceIndir;
  660.  
  661.   PROCEDURE GeaP(VAR x : Item; VAR fea : CARDINAL);
  662.     (* effective address of an item designating a procedure. *)
  663.     VAR An : Register;
  664.   BEGIN
  665.     WITH x DO
  666.       IF (proc <> NIL) & (proc^.pd <> NIL) &
  667.          (proc^.pd^.adr <> 0) THEN (* local procedure *)
  668.         fea := PREL;
  669.       ELSE (* external procedure *)
  670.         GetReg(An,Areg);
  671.         Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + SB);
  672.         Put16((maxP + VAL(CARDINAL,proc^.pmod))*4);
  673.         Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + (An MOD 8));
  674.         Put16(proc^.pd^.num*4);
  675.         (* transform 'procMd' to 'AregMd' *)
  676.         SetregMd(x, An, typ);
  677.         fea := ADIR + (An MOD 8);
  678.       END;
  679.     END (*WITH*);
  680.   END GeaP;
  681.  
  682.   PROCEDURE Gea(VAR x : Item; VAR fea : CARDINAL);
  683.     (* give effective address of x. *)
  684.     VAR ea : CARDINAL; An : Register;
  685.   BEGIN
  686.     WITH x DO
  687.       CASE mode OF
  688.         absMd :             ea := XXXL;
  689.       | RindMd :            IF R = (MP + 8) THEN
  690.                               IF lev <> curLev THEN downlevel(x) END;
  691.                             END;
  692.                             IF adr <> 0 THEN ea := AOFF + (R MOD 8)
  693.                             ELSE ea := AIDR + (R MOD 8) END;
  694.       | RidxMd :            IF (-128 <= adr) & (adr <= 127) THEN
  695.                               ea := AIDX + (R MOD 8)
  696.                             ELSE (* adr out of 8-bit range *)
  697.                               IF Islocked(R) THEN GetReg(An,Areg)
  698.                               ELSE An := R END;
  699.                               Put16(LEA + (An MOD 8)*LS9 + AIDX + (R MOD 8));
  700.                               IF wid = word THEN Put16(RX*LS12 + scl*LS9)
  701.                               ELSE Put16(RX*LS12 + LS11 + scl*LS9) END;
  702.                               IF R <> An THEN ReleaseReg(R) END;
  703.                               ReleaseReg(RX);
  704.                               (* transform 'RidxMd' to 'RindMd' *)
  705.                               mode := RindMd; ea := AOFF + (An MOD 8);
  706.                               R := An;
  707.                             END (*RidxMd*);
  708.       | conMd :             IF typ = stringtyp THEN
  709.                               ea := AOFF + SB (* SB-relative *)
  710.                             ELSE
  711.                               ea := IMM (* for all sizes *)
  712.                             END;
  713.       | stkMd :             ea := AINC + SP;  (* gives (SP)+ *)
  714.       | AregMd :            ea := ADIR + (R MOD 8);
  715.       | DregMd :            ea := DDIR + (R MOD 8);
  716.       | prgMd :             ea := PREL;
  717.       | typMd, codMd :      ea := DDIR + D0; (* dummy effective address *)
  718.                             err(232);        (* NO address equivalent ! *)
  719.       | procMd, cocMd,
  720.         fltMd :             ea := DDIR + D0; (* dummy effective address *)
  721.                             err(233);        (* should never occur here!*)
  722.       END (*CASE*);
  723.       IF (mode < conMd) & indir THEN
  724.         ReduceIndir(x,ea);
  725.         IF adr <> 0 THEN ea := AOFF + (R MOD 8)
  726.         ELSE ea := AIDR + (R MOD 8) END;
  727.       END;
  728.     END (*WITH*);
  729.     fea := ea ; (* resulting effective address *)
  730.   END Gea;
  731.  
  732.   PROCEDURE OvflTrap(signed : BOOLEAN);
  733.     (* overflow-check thru TRAPV for signed arithmetic : *)
  734.   BEGIN
  735.     IF NOT ovflchk THEN RETURN END;
  736.     IF signed THEN Put16(TRAPV) END;
  737.   END OvflTrap;
  738.  
  739.   PROCEDURE OvflCheck(R : Register; signed : BOOLEAN);
  740.     (* overflow-check for 16*16bit signed multiplication : *)
  741.     VAR Dn : Register;
  742.   BEGIN
  743.     IF NOT ovflchk THEN RETURN END;
  744.     IF signed THEN
  745.       GetReg(Dn,Dreg);                     (* scratch reg. *)
  746.       Put16(MOVEW + Dn*LS9 + R);           (* copy wordpart *)
  747.       Put16(EXTL + Dn);                    (* EXT.L Dn      *)
  748.       Put16(CMP + R*LS9 + long*LS6 + Dn);  (* CMP.L  Dn,R   *)
  749.       Put16(BEQ + 6);                      (* BEQ.S  6      *)
  750.       Put16(ORI + IMM);                    (* ORI.W #VBIT,SR*)
  751.       Put16(VBIT);
  752.       Put16(TRAPV);                        (* TRAPV         *)
  753.       ReleaseReg(Dn);
  754.     END;
  755.   END OvflCheck;
  756.  
  757.   PROCEDURE StackTop(i : INTEGER);
  758.     (* increment/decrement stack pointer SP :  *)
  759.     (*   i > 0 :  increment SP, reset stack    *)
  760.     (*   i < 0 :  decrement SP, reserve stack  *)
  761.     VAR neg : BOOLEAN; c : CARDINAL;
  762.   BEGIN
  763.     IF i <> 0 THEN
  764.       neg := (i < 0);
  765.       IF ODD(i) THEN
  766.         IF neg THEN DEC(i) ELSE INC(i) END;
  767.       END;
  768.       IF (-8 <= i) & (i <= 8) THEN
  769.         c := (VAL(CARDINAL,ABS(i)) MOD 8)*LS9;
  770.         IF neg THEN Put16(DECSP + c)
  771.         ELSE Put16(INCSP + c) END;
  772.       ELSE
  773.         Put16(LEASP);
  774.         Put16(i);
  775.       END;
  776.     END (*i <> 0*);
  777.   END StackTop;
  778.  
  779.   PROCEDURE SetupSL(plev : CARDINAL);
  780.     (* push Static Link onto stack. *)
  781.     CONST  offSL = 8;  (* offset of Static Link relative to MP *)
  782.     VAR N, An : Register; n : CARDINAL;
  783.   BEGIN
  784.     IF plev <> 0 THEN
  785.       IF plev = curLev THEN
  786.         (* level difference = 0 *)
  787.         Put16(PEA + AIDR + MP);             (* PEA     (MP) *)
  788.       ELSIF plev + 1 = curLev THEN
  789.         (* level difference = 1 *)
  790.         Put16(MVEMSP + AOFF + MP);          (* MOVE.L  offSL(MP),-(SP) *)
  791.         Put16(offSL);
  792.       ELSE
  793.         (* level difference >= 2 *)
  794.         GetReg(N,Areg); An := N MOD 8;
  795.         Put16(MOVEAL + An*LS9 + AOFF + MP); (* MOVEA.L offSL(MP),An *)
  796.         Put16(offSL);
  797.         n := curLev - plev;
  798.         WHILE n > 2 DO
  799.           DEC(n);
  800.           Put16(MOVEAL + An*LS9 + AOFF+An); (* MOVEA.L offSL(An),An *)
  801.           Put16(offSL);
  802.         END;
  803.         Put16(MVEMSP + AOFF + An);          (* MOVE.L  offSL(An),-(SP) *)
  804.         Put16(offSL);
  805.         ReleaseReg(N);
  806.       END;
  807.     END (*plev <> 0*);
  808.   END SetupSL;
  809.  
  810.   PROCEDURE InitM2HM;
  811.     VAR k : CARDINAL; exp : LONGINT;
  812.   BEGIN
  813.     curLev := 0;
  814.     MoveCode[byte] := MOVEB; MoveCode[word] := MOVEW;
  815.     MoveCode[long] := MOVEL;
  816.     ShiCode [Asl]  := ASL;   ShiCode [Asr]  := ASR;
  817.     ShiCode [Lsl]  := LSL;   ShiCode [Lsr]  := LSR;
  818.     ShiCode [Rol]  := ROL;   ShiCode [Ror]  := ROR;
  819.     exp := 0D; mask[0] := 0D; mask[32] := -1D;
  820.     FOR k := 1 TO 31 DO exp := exp + exp + 1D; mask[k] := exp END;
  821.     IF DynArrDesSize = 6 THEN hightyp := inttyp
  822.     ELSE hightyp := dbltyp END;
  823.     InitRegs;
  824.   END InitM2HM;
  825.  
  826.   PROCEDURE LoadAdr(VAR x : Item);
  827.     (* ADR(x)   --->>>  pointer/address-register. *)
  828.     VAR ea, am, op : CARDINAL; An : Register; newA, loaded : BOOLEAN;
  829.   BEGIN op := LEA;
  830.     WITH x DO
  831.       IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
  832.       OR ((mode = conMd) & (typ <> stringtyp)) THEN
  833.         err(231); (* no effective address possible *)
  834.         Release(x); SetregMd(x, A0+8, undftyp);
  835.       END;
  836.       IF (mode < conMd) & indir & (off=0) THEN op := MOVEAL; indir := FALSE END;
  837.       IF mode = procMd THEN GeaP(x,ea) ELSE Gea(x,ea) END;
  838.       am := (ea DIV 8)*8;
  839.  stkMd) THEN
  840.       IF x.mode = conMd THEN (* NO immediate's for MOVEM! *)
  841.         IF (x.val.D = 0D) THEN Put16(MOVEQ + D0*LS9)
  842.         ELSE Put16(MOVELIMM + D0*LS9); Put16(x.val.D0); Put16(x.val.D1)
  843.         END;
  844.         IF (x.val.D2 = 0) & (x.val.D3 = 0) THEN Put16(MOVEQ + D1*LS9)
  845.         ELSE Put16(MOVELIMM + D1*LS9); Put16(x.val.D2); Put16(x.val.D3)
  846.         END
  847.       ELSE
  848.         Gea(x,ea);
  849.         Put16(MOVEMLDD + ea); Put16(3);  (* for D0/D1 *)
  850.         Ext(x);
  851.         Release(x);
  852.       END;
  853.       IF y.mode = stkMd THEN
  854.         Put16(MOVEMDEC); Put16(140000B); (* for D0/D1 *)
  855.       ELSE
  856.         Gea(y,ea);
  857.         Put16(MOVEMSTD + ea); Put16(3);  (* for D0/D1 *)
  858.         Ext(y);
  859.       END
  860.     END
  861.   END MoveQuad;
  862.  
  863.   PROCEDURE LoadD(VAR x : Item);
  864.     (* load simple type x to a D-Register. *)
  865.     VAR y : Item; Dn : Register;
  866.   BEGIN
  867.     WITH x DO
  868.       IF mode < DregMd THEN
  869.         GetReg(Dn,Dreg);
  870.         SetregMd(y, Dn, typ);
  871.         Move(x,y);
  872.         Release(x);
  873.         x := y;
  874.       ELSIF mode = cocMd THEN LoadCC(x)
  875.       ELSIF mode > DregMd THEN
  876.         err(230); Release(x);
  877.         SetregMd(x, D0, typ);
  878.       END;
  879.     END (*WITH*);
  880.   END LoadD;
  881.  
  882.   PROCEDURE CheckPointer(VAR x : Item);
  883.     (* check x to be a non-NIL pointer *)
  884.   BEGIN
  885.     IF NOT(rngchk) OR (x.typ = addrtyp) THEN RETURN END;
  886.     LoadD(x);
  887.     Put16(BNE + 12); (* if NOT NIL-pointer *)
  888.     GenHalt(5);      (* halt if NIL-pointer *)
  889.   END CheckPointer;
  890.  
  891.   PROCEDURE LoadP(VAR x : Item);
  892.     (* load simple type or pointer to a pointer/address-register. *)
  893.     VAR y : Item; An : Register;
  894.   BEGIN
  895.     WITH x DO
  896.       IF (mode IN ItSet{RindMd,RidxMd}) & NOT(Islocked(R)) THEN
  897.         SetregMd(y, R, typ);
  898.         Move(x,y);
  899.         SetbusyReg(R);  (* do NOT release register R *)
  900.         IF mode = RidxMd THEN ReleaseReg(RX) END;
  901.         x := y;
  902.       ELSIF (mode < AregMd) OR (mode = DregMd) THEN
  903.         GetReg(An,Areg);
  904.         SetregMd(y, An, typ);
  905.         Move(x,y);
  906.         Release(x);
  907.         x := y;
  908.       ELSIF (mode <> AregMd) THEN
  909.         err(230); Release(x);
  910.         SetregMd(x, A0+8, typ);
  911.       END;
  912.     END (*WITH*);
  913.   END LoadP;
  914.  
  915.   PROCEDURE LoadX(VAR x : Item; req : WidType);
  916.     (* load simple type x to a D-Register and    *)
  917.     (* sign extend it to the width given by req. *)
  918.  
  919.     VAR y : Item; Dn : Register; sz : WidType;
  920.         cload, signar : BOOLEAN; lv : LONGINT;
  921.  
  922.     PROCEDURE NewLoadX(VAR old, new : Item);
  923.     BEGIN
  924.       GetReg(Dn,Dreg);
  925.       SetregMd(new, Dn, old.typ);
  926.       IF NOT(signar) & (sz < req) & (sz < long) THEN
  927.         Put16(MOVEQ + Dn*LS9);
  928.       END;
  929.       Move(old,new);
  930.       Release(old);
  931.       IF signar & (sz < req) & (sz < long) THEN
  932.         IF req = word THEN Put16(EXTW + Dn)
  933.         ELSIF sz = byte THEN Put16(EXTBL + Dn)
  934.         ELSE (* sz = word *) Put16(EXTL + Dn)
  935.         END;
  936.       END;
  937.       new.wid := req;
  938.     END NewLoadX;
  939.  
  940.   BEGIN (* LoadX *)
  941.     IF x.mode = cocMd THEN LoadCC(x) END;
  942.     Isz(x,sz);
  943.     cload := SimpleC(x); (* Real constants not included *)
  944.     signar := SignedT(x);
  945.     WITH x DO
  946.       IF cload THEN
  947.         (* constants always loaded to long width. *)
  948.         lv := LongVal(x);
  949.         GetReg(Dn,Dreg); SetregMd(y, Dn, typ);
  950.         IF (lv >= -128D) & (lv <= 127D) THEN
  951.           Put16(MOVEQ + Dn*LS9 + (VAL(CARDINAL, WordVal(x)) MOD 256));
  952.         ELSE (* not quick *)
  953.           Put16(MOVEL + Dn*LS9 + IMM);
  954.           Put32(lv);
  955.         END;
  956.         y.wid := req; (* long satisfies req anyway *)
  957.         x := y;
  958.       ELSIF (mode = DregMd) THEN
  959.         (* x is already in a D-Register. *)
  960.         IF wid < req THEN
  961.           IF req = word THEN
  962.             IF sz = byte THEN
  963.               IF signar THEN Put16(EXTW + R)
  964.               ELSE (* unsigned types *)
  965.                 Put16(ANDI + word*LS6 + R);
  966.                 Put16(377B);
  967.               END;
  968.             END;
  969.           ELSIF req = long THEN
  970.             IF signar THEN
  971.               IF sz < long THEN
  972.                 IF sz = byte THEN Put16(EXTBL + R)
  973.                 ELSE Put16(EXTL + R) END;
  974.               END;
  975.             ELSE (* unsigned types *)
  976.               IF sz < long THEN
  977.                 Put16(ANDI + long*LS6 + R);
  978.                 IF sz = byte THEN Put32(255D) ELSE Put32(65535D) END;
  979.               END;
  980.             END;
  981.           END;
  982.         END (*wid < req*);
  983.         wid := req;
  984.       ELSIF (mode <= AregMd) THEN
  985.         (* Real constants fall into this variant. *)
  986.         NewLoadX(x,y);
  987.         x := y;
  988.       ELSE
  989.         err(230); Release(x);
  990.         SetregMd(x, D0, typ);
  991.       END;
  992.     END (*WITH*);
  993.   END LoadX;
  994.  
  995.   PROCEDURE MoveAdr(VAR x, y : Item);
  996.     (*   ADR(x)   --->>>  y      *)
  997.     VAR op, src, dst : CARDINAL; o, s : StrPtr;
  998.   BEGIN
  999.     WITH x DO
  1000.       o := typ;   (* save original type of x *)
  1001.       s := y.typ; (* save original type of y *)
  1002.       IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
  1003.       OR ((mode = conMd) & (typ <> stringtyp)) THEN
  1004.         err(231); (* no effective address possible *)
  1005.         Release(x); SetregMd(x, A0+8, undftyp);
  1006.       END;
  1007.       IF y.mode = stkMd THEN (* push address of x *)
  1008.         op := 0;
  1009.         IF (mode < conMd) & indir & (off = 0) THEN
  1010.           indir := FALSE; op := MVEMSP;
  1011.         END;
  1012.         IF mode = procMd THEN GeaP(x,src) ELSE Gea(x,src) END;
  1013.         IF mode = AregMd THEN
  1014.           op := MVEMSP;   (* MOVE.L An,-(SP) *)
  1015.         ELSIF op = 0 THEN
  1016.           op := PEA;
  1017.         END;
  1018.         Put16(op + src);
  1019.         Ext(x);
  1020.       ELSE (* move address of x *)
  1021.         IF (mode < conMd) & indir & (off = 0) THEN
  1022.           indir := FALSE;
  1023.         ELSE
  1024.           LoadAdr(x);
  1025.         END;
  1026.         typ := addrtyp; y.typ := addrtyp;
  1027.         Move(x,y);
  1028.         IF y.mode = DregMd THEN y.wid := long END;
  1029.       END;
  1030.       typ := o;    (* restore original type of x *)
  1031.       y.typ := s;  (* restore original type of y *)
  1032.     END (*WITH*);
  1033.     Release(x);  (* release associated registers *)
  1034.   END MoveAdr;
  1035.  
  1036.   PROCEDURE MoveBlock(VAR x, y : Item; sz : INTEGER; isstring : BOOLEAN);
  1037.     (*  Move a block of 'sz' bytes from x to y.  *)
  1038.     (*                                           *)
  1039.     (*  x.mode = stkMd :  block comes from stack *)
  1040.     (*  y.mode = stkMd :  block goes onto stack  *)
  1041.     (*                                           *)
  1042.     (* Dogma : the implementation below presumes *)
  1043.     (* -----   that all arrays and records are   *)
  1044.     (*         allocated on a Word-boundary.     *)
  1045.     (*                                           *)
  1046.     VAR hsz, op, src, dst : CARDINAL; z : Item; xmode : ItemMode;
  1047.   BEGIN
  1048.     IF (x.mode <> stkMd) OR (y.mode <> stkMd) THEN
  1049.       xmode := x.mode; (* save original mode of source op. *)
  1050.       IF y.mode = stkMd THEN
  1051.         StackTop( - sz );
  1052.         y.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  1053.       END;
  1054.       IF x.mode = stkMd THEN
  1055.         x.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  1056.       END;
  1057.       LoadAdr(x); src := AINC + (x.R MOD 8);
  1058.       LoadAdr(y); dst := AINC + (y.R MOD 8);
  1059.       op := MOVEB; hsz := sz;
  1060.       IF NOT isstring THEN
  1061.         (* Note : always byte - move for Strings due to DBEQ! *)
  1062.         IF    (hsz MOD 4) = 0 THEN op := MOVEL; hsz := hsz DIV 4
  1063.         ELSIF (hsz MOD 2) = 0 THEN op := MOVEW; hsz := hsz DIV 2
  1064.         END;
  1065.       END;
  1066.       op := op + Iea(dst)*LS6 + src;
  1067.       IF    hsz = 1 THEN Put16(op)
  1068.       ELSIF hsz = 2 THEN Put16(op); Put16(op)
  1069.       ELSIF hsz = 3 THEN Put16(op); Put16(op); Put16(op)
  1070.       ELSIF hsz > 0 THEN
  1071.         SetconMd(z, hsz - 1, inttyp);
  1072.         LoadD(z);
  1073.         Put16(op);
  1074.         IF isstring THEN Put16(DBEQ + z.R)
  1075.         ELSE Put16(DBRA + z.R) END;
  1076.         Put16(177774B);
  1077.         ReleaseReg(z.R);
  1078.       END;
  1079.       IF xmode = stkMd THEN StackTop( sz ) END;
  1080.     END;
  1081.   END MoveBlock;
  1082.  
  1083.   PROCEDURE ConvertTyp(functyp : StrPtr; VAR x : Item);
  1084.     VAR fs, xs : INTEGER; szf, szx : WidType; y : Item;
  1085.   BEGIN
  1086.     SetregMd(y, D0, functyp);  (* dummy for SimpleT *)
  1087.     WITH x DO
  1088.       fs := functyp^.size;
  1089.       xs := typ^.size;
  1090.       IF fs <> xs THEN
  1091.         IF SimpleT(x) & SimpleT(y) THEN
  1092.           Isz(x,szx); Isz(y,szf);
  1093.           IF mode = conMd THEN
  1094.             SetconMd(x, LongVal(x), functyp);
  1095.           ELSIF (mode <= DregMd) OR (mode = cocMd) THEN
  1096.             IF szf <= szx THEN LoadD(x)
  1097.             ELSE LoadX(x,szf) END;
  1098.           ELSE err(81); Release(x);
  1099.           END;
  1100.         ELSE err(81); Release(x);
  1101.         END;
  1102.       END;
  1103.       typ := functyp; (* type of x IS changed ! *)
  1104.       IF (mode = DregMd) & SimpleT(y) THEN Isz(y,wid) END;
  1105.     END (*WITH*);
  1106.   END ConvertTyp;
  1107.  
  1108.   PROCEDURE CallSystem(sysp : CARDINAL);
  1109.     (* call System.#sysp where sysp = ordinal of procedure.  *)
  1110.   BEGIN
  1111.     ExternalCall(maxM - 1, sysp);
  1112.   END CallSystem;
  1113.  
  1114.   PROCEDURE GenHalt(haltindex : CARDINAL);
  1115.   BEGIN
  1116.     haltindex := haltindex MOD 256;
  1117.     IF (haltindex <> 0) & NOT(rngchk) THEN RETURN END;
  1118.     Put16(MOVEQ + D0*LS9 + haltindex);
  1119.     CallSystem(HALTX);
  1120.   END GenHalt;
  1121.  
  1122.   PROCEDURE Op1(op : CARDINAL; VAR x : Item);
  1123.     (* generate instructions with 1 operand represented   *)
  1124.     (* by an eff. address in bits [0..5] and its variable *)
  1125.     (* size in bits [6..7] of the instruction word.       *)
  1126.     (* Used for CLR, TST, NEG, COM (=NOT), INC1, DEC1.    *)
  1127.     (* Not used for JSR, JMP, PEA, Scc because these      *)
  1128.     (* instructions have a fixed size.                    *)
  1129.     (* Note : x can be a memory location or on TOS.       *)
  1130.     VAR ea : CARDINAL; sz : WidType;
  1131.   BEGIN
  1132.     Isz(x,sz);
  1133.     Gea(x,ea);
  1134.     WITH x DO
  1135.       IF mode = stkMd THEN
  1136.         (* change (SP)+ to (SP). *)
  1137.         (* for TST the operand is popped from stack! *)
  1138.         IF op <> TST THEN ea := AIDR + SP END;
  1139.       END;
  1140.       Put16(op + sz*LS6 + ea);
  1141.       Ext(x);
  1142.       IF mode = DregMd THEN wid := sz END;
  1143.     END (*WITH*);
  1144.   END Op1;
  1145.  
  1146.   PROCEDURE Power2(VAR x : Item; VAR exp2 : CARDINAL) : BOOLEAN;
  1147.     (* Note : negative numbers must NOT return as power of 2. *)
  1148.     VAR pw2 : BOOLEAN;
  1149.         v   : LONGINT;
  1150.   BEGIN
  1151.     exp2 := 0; pw2 := FALSE;
  1152.     IF SimpleC(x) THEN
  1153.       v := LongVal(x);
  1154.       pw2 := (v >= 1D);              (* 1 = 2**0 *)
  1155.       WHILE (v > 1D) & pw2 DO
  1156.         pw2 := NOT ODD(v);
  1157.         v := SHIFT(v, -1);           (* v := v DIV 2D;  *)
  1158.         INC(exp2);                   (* side effect of Power2 *)
  1159.       END;
  1160.     END;
  1161.     RETURN pw2                       (* 0 <= exp2 <= 31 *)
  1162.   END Power2;
  1163.  
  1164.   PROCEDURE MulPw2(VAR x : Item; exp : CARDINAL; ovfl : BOOLEAN);
  1165.     (*       x * (power of 2)               *)
  1166.     (* relevant is the width, not the size! *)
  1167.     VAR op : CARDINAL; Dn : Register;
  1168.   BEGIN
  1169.     IF exp <> 0 THEN
  1170.       IF SignedT(x) THEN op := ASL ELSE op := LSL END;
  1171.       op := op + x.wid*LS6 + x.R;
  1172.       IF exp IN {1..8} THEN (* immediate shift *)
  1173.         Put16(op + (exp MOD 8)*LS9);
  1174.       ELSE (* register by register shift *)
  1175.         GetReg(Dn,Dreg);
  1176.         Put16(MOVEQ + Dn*LS9 + exp);
  1177.         Put16(op + Dn*LS9 + LS5);
  1178.         ReleaseReg(Dn);
  1179.       END;
  1180.       IF ovfl THEN OvflTrap(SignedT(x)) END;
  1181.       (* do not change x.wid *)
  1182.     END (*exp <> 0*);
  1183.   END MulPw2;
  1184.  
  1185.   PROCEDURE MUL2(VAR x, y : Item; ovfl : BOOLEAN);
  1186.     (*  x  *  y  --->>  x  *)
  1187.     VAR op, ea, pw2 : CARDINAL; szx, szy : WidType;
  1188.         signar, loady : BOOLEAN;
  1189.   BEGIN
  1190.     Isz(x,szx); Isz(y,szy);
  1191.     signar := SignedT(x) OR SignedT(y);
  1192.     loady  := y.mode IN ItSet{AregMd,stkMd};
  1193.     IF szx < long THEN (* szy < long expected *)
  1194.       (* 16 * 16 bits *)
  1195.       IF (szy = byte) OR loady THEN LoadX(y,word) END;
  1196.       LoadX(x,word);  (* assert DregMd for destination *)
  1197.       IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
  1198.       ELSE
  1199.         IF signar THEN op := MULS ELSE op := MULU END;
  1200.         Gea(y,ea);
  1201.         Put16(op + x.R*LS9 + ea);
  1202.         Ext(y);
  1203.         x.wid := long;
  1204.         IF ovfl THEN OvflCheck(x.R, signar) END;
  1205.       END;
  1206.     ELSE
  1207.       (* 32 * 32 bits *)
  1208.       IF (szy < long) OR loady THEN LoadX(y,long) END;
  1209.       LoadX(x,long);  (* assert DregMd for destination *)
  1210.       IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
  1211.       ELSE
  1212.         op := x.R*LS12;
  1213.         IF signar THEN op := op + LS11 END;
  1214.         Gea(y,ea);
  1215.         Put16(MULL + ea); Put16(op);
  1216.         Ext(y);
  1217.         (* x.wid remains long. *)
  1218.         IF ovfl THEN OvflTrap(signar) END;
  1219.       END;
  1220.     END;
  1221.     Release(y);
  1222.   END MUL2;
  1223.  
  1224.   PROCEDURE SHI2(inst : CARDINAL; VAR x, y : Item);
  1225.     (*  shift left/right x by y.  *)
  1226.     VAR op, cv : CARDINAL; szx : WidType; lv : LONGINT; imm : BOOLEAN;
  1227.   BEGIN
  1228.     IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1229.     LoadD(x);
  1230.     Isz(x,szx);
  1231.     op := inst + szx*LS6 + x.R; (* register to be shifted *)
  1232.     imm := FALSE;
  1233.     IF SimpleC(y) THEN
  1234.       lv := LongVal(y);
  1235.       IF (lv >= 1D) & (lv <= 8D) THEN imm := TRUE END;
  1236.     END;
  1237.     IF imm THEN (* immediate shift : value 0 excluded *)
  1238.       cv := VAL(CARDINAL, lv) MOD 8;
  1239.       Put16(op + cv*LS9);
  1240.     ELSE (* register by register shift *)
  1241.       LoadD(y);                 (* load shift count *)
  1242.       op := op + y.R*LS9 + LS5; (* indicates register shift *)
  1243.       (* shift is modulo 64 : no chechs are made for *)
  1244.       (* positive or negative values of shift count. *)
  1245.       Put16(op);
  1246.     END;
  1247.     x.wid := szx; (* resulting width of D-Register *)
  1248.     Release(y);
  1249.   END SHI2;
  1250.  
  1251.   PROCEDURE LOG2(inst : CARDINAL; VAR x, y : Item);
  1252.     (* the logical operators AND, OR, EOR.  *)
  1253.     (*      x   AND   y  --->>   x          *)
  1254.     (*      x   OR    y  --->>   x          *)
  1255.     (*      x   EOR   y  --->>   x          *)
  1256.     (* Note : x can be a memory location *)
  1257.     (*        or on top of stack.        *)
  1258.     VAR op, eax, eay : CARDINAL; szx, szy : WidType;
  1259.   BEGIN
  1260.     Isz(x,szx); Isz(y,szy);
  1261.     Gea(x,eax);
  1262.     IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
  1263.     IF SimpleC(y) & (x.mode <> AregMd) THEN
  1264.       (* ANDI / ORI / EORI *)
  1265.       IF inst = ANDL THEN op := ANDI
  1266.       ELSIF inst = ORL THEN op := ORI
  1267.       ELSE op := EORI END;
  1268.       Put16(op + szx*LS6 + eax);
  1269.       Ext(y); (* source extension first *)
  1270.       Ext(x); (* destination extension  *)
  1271.     ELSE
  1272.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1273.       IF x.mode = AregMd THEN LoadD(x); Gea(x,eax) END;
  1274.       op := inst + szx*LS6;
  1275.       Gea(y,eay);
  1276.       IF (x.mode = DregMd) & (inst <> EORL) THEN
  1277.         (* destination is D-Register : *)
  1278.         Put16(op + x.R*LS9 + eay);
  1279.         Ext(y); (* source extension *)
  1280.       ELSE
  1281.         (* destination is memory location or inst = EOR. *)
  1282.         (* assert source operand in D-Register.          *)
  1283.         LoadD(y);
  1284.         IF (inst <> EORL) THEN
  1285.           op := op + LS8;
  1286.         END;
  1287.         Put16(op + y.R*LS9 + eax);
  1288.         Ext(x); (* destination extension *)
  1289.       END;
  1290.     END;
  1291.     IF x.mode = DregMd THEN x.wid := szx END;
  1292.     Release(y);
  1293.   END LOG2;
  1294.  
  1295.   PROCEDURE DivPw2(VAR x : Item; exp : CARDINAL; modulus : BOOLEAN);
  1296.     VAR m : LONGINT; y : Item;
  1297.   BEGIN
  1298.     IF exp = 0 THEN (* DIV/MOD 1 *)
  1299.       IF modulus THEN Release(x); SetconMd(x, 0D, x.typ) END;
  1300.       (* else no change if x DIV 1 *)
  1301.     ELSE
  1302.       LoadD(x);
  1303.       IF NOT modulus THEN (* DIV *)
  1304.         SetconMd(y, exp, inttyp);
  1305.         IF SignedT(x) THEN SHI2(ASR,x,y)
  1306.         ELSE SHI2(LSR,x,y)
  1307.         END;
  1308.       ELSE (* MOD *)
  1309.         m := mask[exp];  (* 2**exp - 1 *)
  1310.         SetconMd(y, m, x.typ);
  1311.         LOG2(ANDL,x,y);
  1312.       END;
  1313.     END;
  1314.     (* x.wid is set by SHI2 and LOG2 *)
  1315.     Release(y);
  1316.   END DivPw2;
  1317.  
  1318.   PROCEDURE DIV2(VAR x, y : Item; modulus : BOOLEAN);
  1319.     (*  x  DIV/MOD  y  --->>  x  *)
  1320.     VAR op, ea, pw2 : CARDINAL; szx, szy : WidType;
  1321.         signar, loady : BOOLEAN;
  1322.   BEGIN
  1323.     Isz(x,szx); Isz(y,szy);
  1324.     signar := SignedT(x) OR SignedT(y);
  1325.     loady  := y.mode IN ItSet{AregMd,stkMd};
  1326.     IF szx < long THEN (* szy < long expected *)
  1327.       (* 32 DIV/MOD 16 bits *)
  1328.       IF (szy = byte) OR loady THEN LoadX(y,word) END;
  1329.       IF NOT(signar) & Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
  1330.       ELSE (* extend destination to 32 bits *)
  1331.         LoadX(x,long); (* assert DregMd for destination *)
  1332.         IF signar THEN op := DIVS ELSE op := DIVU END;
  1333.         Gea(y,ea);
  1334.         Put16(op + x.R*LS9 + ea);
  1335.         Ext(y); (* extend the source *)
  1336.         OvflTrap(signar); (* for security reasons *)
  1337.         (* quotient in bits [0..15], remainder in bits [16..31] *)
  1338.         IF modulus THEN Put16(SWAP + x.R) END;
  1339.         x.wid := word; (* resulting width *)
  1340.       END;
  1341.     ELSE
  1342.       (* 32 DIV/MOD 32 bits *)
  1343.       IF (szy < long) OR loady THEN LoadX(y,long) END;
  1344.       IF NOT(signar) & Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
  1345.       ELSE
  1346.         LoadX(x,long);  (* assert DregMd for destination *)
  1347.         op := x.R*LS12; (* Dq = x.R, Dr = D0 *)
  1348.         IF signar THEN op := op + LS11 END;
  1349.         Gea(y,ea);
  1350.         Put16(DIVL + ea); Put16(op);
  1351.         Ext(y);
  1352.         (* quotient in x.R, remainder in D0 *)
  1353.         IF modulus THEN Put16(MOVEL + x.R*LS9) END;
  1354.         (* x.wid remains long. *)
  1355.       END;
  1356.     END;
  1357.     Release(y);
  1358.   END DIV2;
  1359.  
  1360.   PROCEDURE ADD2(inst : CARDINAL; VAR x, y : Item);
  1361.     (*       x  +  y    --->>   x        *)
  1362.     (*       x  -  y    --->>   x        *)
  1363.     (* Note : x can be a memory location *)
  1364.     (*        or on top of stack.        *)
  1365.     VAR op, eax, eay : CARDINAL; szx, szy : WidType;
  1366.         cadd : BOOLEAN; lv : LONGINT;
  1367.   BEGIN
  1368.     Isz(x,szx); Isz(y,szy);
  1369.     Gea(x,eax);
  1370.     IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
  1371.     cadd := SimpleC(y);
  1372.     IF cadd THEN lv := LongVal(y) END;
  1373.     IF cadd & (x.mode <> AregMd) THEN
  1374.       IF (lv >= 1D) & (lv <= 8D) THEN
  1375.         IF inst = ADD THEN op := ADDQ ELSE op := SUBQ END;
  1376.         eay := VAL(CARDINAL, lv) MOD 8;
  1377.         Put16(op + eay*LS9 + szx*LS6 + eax);
  1378.         Ext(x);
  1379.       ELSIF (lv <> 0D) THEN
  1380.         IF inst = ADD THEN op := ADDI ELSE op := SUBI END;
  1381.         Put16(op + szx*LS6 + eax);
  1382.         Ext(y); (* extend source constant first *)
  1383.         Ext(x); (* extend destination *)
  1384.       END;
  1385.     ELSE
  1386.       IF inst = ADD THEN op := ADD ELSE op := SUB END;
  1387.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1388.       Gea(y,eay);
  1389.       IF x.mode = DregMd THEN
  1390.         (* destination is D-Register : *)
  1391.         op := op + (x.R MOD 8)*LS9;
  1392.         IF y.mode = AregMd THEN
  1393.           (* allow word/long only for source in A-Reg. *)
  1394.           IF szy = byte THEN err(288) END;
  1395.         END;
  1396.         Put16(op + szx*LS6 + eay);
  1397.         Ext(y); (* extend source *)
  1398.       ELSIF x.mode = AregMd THEN
  1399.         (* destination is A-Register : *)
  1400.         op := op + (x.R MOD 8)*LS9;
  1401.         (* allow long operation only. *)
  1402.         IF szx < long THEN err(287) END;
  1403.         Put16(op + 700B + eay); (* 700B generates ADDA.L *)
  1404.         Ext(y); (* extend source *)
  1405.       ELSE
  1406.         (* destination is memory location : *)
  1407.         (* assert source op. in D-Register. *)
  1408.         LoadD(y);
  1409.         op := op + y.R*LS9 + LS8;
  1410.         Put16(op + szx*LS6 + eax);
  1411.         Ext(x); (* extend destination *)
  1412.       END;
  1413.     END;
  1414.     IF x.mode = DregMd THEN x.wid := szx END;
  1415.     Release(y);
  1416.   END ADD2;
  1417.  
  1418.   PROCEDURE Cmp2(VAR x, y : Item);
  1419.     (*         x   -   y                 *)
  1420.     (* Note : x can be a memory location *)
  1421.     (*        or on top of stack.        *)
  1422.     VAR op, eax, eay : CARDINAL; szx, szy : WidType; lv : LONGINT;
  1423.   BEGIN
  1424.     Isz(x,szx); Isz(y,szy);
  1425.     Gea(x,eax);
  1426.     IF SimpleC(y) & NOT(x.mode IN ItSet{AregMd,conMd}) THEN
  1427.       (* source is constant : *)
  1428.       lv := LongVal(y);
  1429.       IF lv = 0D THEN Op1(TST,x)   (* x would be popped if stkMd *)
  1430.       ELSE op := CMPI;
  1431.         Put16(op + szx*LS6 + eax); (* x would be popped if stkMd *)
  1432.         Ext(y); (* immediate source *)
  1433.         Ext(x); (* extend destination *)
  1434.       END;
  1435.     ELSIF x.mode = AregMd THEN
  1436.       (* destination is A-Register : *)
  1437.       Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
  1438.       (* allow long operation only. *)
  1439.       IF szx < long THEN err(287) END;
  1440.       Put16(op + 700B + eay); (* 700B generates CMPA.L *)
  1441.       Ext(y); (* extend source *)
  1442.     ELSE
  1443.       (* destination must be D-Register : *)
  1444.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1445.       LoadD(x);
  1446.       Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
  1447.       IF y.mode = AregMd THEN
  1448.         (* allow word/long only for source in A-Reg. *)
  1449.         IF szy = byte THEN err(288) END;
  1450.       END;
  1451.       Put16(op + szx*LS6 + eay);   (* y would be popped if stkMd *)
  1452.       Ext(y); (* extend source *)
  1453.     END;
  1454.     Release(y);
  1455.     (* result is in the condition code register! *)
  1456.   END Cmp2;
  1457.  
  1458.   PROCEDURE In2(VAR x, y : Item);
  1459.     (* perform bit-manipulations : BTST.  *)
  1460.     (* y is the destination bit pattern,  *)
  1461.     (* x is the bit number.               *)
  1462.  
  1463.     (*   Caution : NEVER execute a BTST-instruction if     *)
  1464.     (*   the bit number is greather than the width of the  *)
  1465.     (*   set, because hardware takes count modulo 32.      *)
  1466.  
  1467.     VAR op : CARDINAL;
  1468.         v, min, max : INTEGER;
  1469.         sz : WidType;
  1470.         Dn : Register;
  1471.   BEGIN
  1472.     (* width of set defines allowed bit-numbers *)
  1473.     Isz(y,sz); min := 0;
  1474.     max := SHIFT(8, sz) - 1;
  1475.     IF SimpleC(x) & NOT SimpleC(y) THEN
  1476.       (* static bit : *)
  1477.       v := WordVal(x);
  1478.       IF (v < min) OR (v > max) THEN
  1479.         (* inhibit BTST :   *)
  1480.         (* force Z-Bit = 1. *)
  1481.         GetReg(Dn,Dreg);
  1482.         Put16(MOVEQ + Dn*LS9);
  1483.         ReleaseReg(Dn);
  1484.       ELSE
  1485.         LoadD(y); (* load bit pattern *)
  1486.         op := BTST + LS11 - LS8 + y.R;
  1487.         Put16(op);
  1488.         Put16(v);
  1489.       END;
  1490.     ELSE
  1491.       (* dynamic bit : *)
  1492.       LoadD(y);                        (* load bit pattern    *)
  1493.       LoadD(x);                        (* load bit number     *)
  1494.       op := BTST + x.R*LS9 + y.R;
  1495.       Put16(CMPI + x.wid*LS6 + x.R);   (* CMPI    #maxi,bitnr *)
  1496.       IF x.wid = long THEN             (* inhibit BTST if     *)
  1497.         Put32(max)                     (* bitnr out of width  *)
  1498.       ELSE                             (* of the set          *)
  1499.         Put16(max)
  1500.       END;
  1501.       Put16(BLS + 4);                  (* if bitnr in range   *)
  1502.       Put16(MOVEQ + x.R*LS9);          (* force Z-Bit = 1     *)
  1503.       Put16(BRA + 2);                  (* skip bitop-instr.   *)
  1504.       Put16(op);                       (* dynamic bitop       *)
  1505.     END;
  1506.     Release(y);
  1507.     (* result is in the condition code register! *)
  1508.   END In2;
  1509.  
  1510.   PROCEDURE Neg1(VAR x : Item);
  1511.   BEGIN
  1512.     LoadD(x);
  1513.     Op1(NEG,x);
  1514.     OvflTrap(SignedT(x));
  1515.   END Neg1;
  1516.  
  1517.   PROCEDURE Abs1(VAR x : Item);
  1518.   BEGIN
  1519.     LoadD(x);
  1520.     Op1(TST,x);
  1521.     Put16(BGE + 2);
  1522.     Op1(NEG,x); (* gives exactly one 16-bit instruction *)
  1523.     OvflTrap(SignedT(x));
  1524.   END Abs1;
  1525.  
  1526.   PROCEDURE Cap1(VAR x : Item);
  1527.   BEGIN
  1528.     LoadD(x);
  1529.     Put16(CMPI + byte*LS6 + x.R); Put16(97);
  1530.     Put16(BCS + 10);
  1531.     Put16(CMPI + byte*LS6 + x.R); Put16(122);
  1532.     Put16(BHI + 4);
  1533.     Put16(ANDI + byte*LS6 + x.R); Put16(95);
  1534.   END Cap1;
  1535.  
  1536.   PROCEDURE Tst1(VAR x : Item);
  1537.   BEGIN
  1538.     IF x.mode IN ItSet{conMd,AregMd} THEN LoadD(x) END;
  1539.     Op1(TST,x);
  1540.   END Tst1;
  1541.  
  1542.   PROCEDURE Com1(VAR x : Item);
  1543.   BEGIN
  1544.     LoadD(x);
  1545.     Op1(COM,x);
  1546.   END Com1;
  1547.  
  1548.   PROCEDURE Inc1(VAR x : Item);
  1549.   BEGIN
  1550.     Op1(INC1,x);
  1551.     OvflTrap(SignedT(x));
  1552.   END Inc1;
  1553.  
  1554.   PROCEDURE Dec1(VAR x : Item);
  1555.   BEGIN
  1556.     Op1(DEC1,x);
  1557.     OvflTrap(SignedT(x));
  1558.   END Dec1;
  1559.  
  1560.   PROCEDURE Add2(VAR x, y : Item);
  1561.     VAR op : CARDINAL; lv : LONGINT;
  1562.   BEGIN op := ADD;
  1563.     IF y.mode = conMd THEN lv := LongVal(y);
  1564.       IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := SUB END;
  1565.     END;
  1566.     ADD2(op,x,y);
  1567.     IF x.mode <> AregMd THEN OvflTrap(SignedT(x)) END;
  1568.   END Add2;
  1569.  
  1570.   PROCEDURE Sub2(VAR x, y : Item);
  1571.     VAR op : CARDINAL; lv : LONGINT;
  1572.   BEGIN op := SUB;
  1573.     IF y.mode = conMd THEN lv := LongVal(y);
  1574.       IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := ADD END;
  1575.     END;
  1576.     ADD2(op,x,y);
  1577.     IF x.mode <> AregMd THEN OvflTrap(SignedT(x)) END;
  1578.   END Sub2;
  1579.  
  1580.   PROCEDURE And2(VAR x, y : Item);
  1581.   BEGIN
  1582.     LOG2(ANDL,x,y);
  1583.   END And2;
  1584.  
  1585.   PROCEDURE Or2(VAR x, y : Item);
  1586.   BEGIN
  1587.     LOG2(ORL,x,y);
  1588.   END Or2;
  1589.  
  1590.   PROCEDURE Eor2(VAR x, y : Item);
  1591.   BEGIN
  1592.     LOG2(EORL,x,y);
  1593.   END Eor2;
  1594.  
  1595.   PROCEDURE Div2(VAR x, y : Item);
  1596.   BEGIN
  1597.     IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
  1598.     ELSE DIV2(x,y, FALSE)
  1599.     END;
  1600.   END Div2;
  1601.  
  1602.   PROCEDURE Mod2(VAR x, y : Item);
  1603.   BEGIN
  1604.     IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
  1605.     ELSE DIV2(x,y, TRUE)
  1606.     END;
  1607.   END Mod2;
  1608.  
  1609.   PROCEDURE Mul2(VAR x, y : Item);
  1610.   BEGIN
  1611.     IF ((y.mode = conMd) & (LongVal(y) = 0D)) THEN
  1612.       Release(x); SetconMd(x, 0D, x.typ)
  1613.     ELSIF NOT((y.mode = conMd) & (LongVal(y) = 1D)) THEN
  1614.       MUL2(x,y,TRUE)
  1615.     END;
  1616.   END Mul2;
  1617.  
  1618.   PROCEDURE Shi2(VAR x, y : Item; shiftop : ShiType);
  1619.   BEGIN
  1620.     SHI2( ShiCode[shiftop], x, y);
  1621.   END Shi2;
  1622.  
  1623.   PROCEDURE Ash2(VAR x, y : Item; shiftop : ShiType);
  1624.     (*                                         *)
  1625.     (*     Arithmetic Shift                    *)
  1626.     (*     Logical Shift        x by y.        *)
  1627.     (*     Rotate Shift                        *)
  1628.     (*                                         *)
  1629.     (*  y is the shift count of type INTEGER   *)
  1630.     (*  or CARDINAL.                           *)
  1631.     (*  if y >= 0 then shift LEFT.             *)
  1632.     (*  if y <  0 then shift RIGHT.            *)
  1633.     (*                                         *)
  1634.     VAR op, ct, rm : CARDINAL; sz : WidType;
  1635.   BEGIN
  1636.     Isz(x,sz);
  1637.     op := ShiCode[shiftop] + sz*LS6 + (x.R MOD 8); (* initially LEFT shift *)
  1638.     IF y.mode = conMd THEN
  1639.       (* immediate shift count : bit 5 remains 0! *)
  1640.       ct := VAL(CARDINAL, WordVal(y));
  1641.       IF VAL(INTEGER,ct) < 0 THEN
  1642.         op := op - LS8; (* RIGHT shift *)
  1643.         (* Note : overflow-checks must be OFF for compiler! *)
  1644.         ct := ABS(VAL(INTEGER,ct));
  1645.       END;
  1646.       ct := ct MOD 32; (* shift count modulo 32 *)
  1647.       rm := ct MOD 8; ct := ct DIV 8;
  1648.       IF rm <> 0 THEN Put16(op + rm*LS9) END;
  1649.       WHILE ct > 0 DO Put16(op); DEC(ct) END;
  1650.     ELSE
  1651.       (* variable shift count of type INTEGER/CARDINAL : *)
  1652.       (* INTEGER/CARDINAL count treated the same way.    *)
  1653.       (* Note : Hardware takes shift count modulo 64 !   *)
  1654.       LoadX(y,word);                     (* load shift count  *)
  1655.       op := op + y.R*LS9 + LS5;          (* register shift    *)
  1656.       Put16(TST + word*LS6 + y.R);       (* test shift count  *)
  1657.       Put16(BPL + 6);                    (* if count >= 0     *)
  1658.       Put16(NEG + word*LS6 + y.R);       (* abs. value count  *)
  1659.       Put16(op - LS8);                   (* RIGHT shift       *)
  1660.       Put16(BRA + 2);                    (* skip next instr.  *)
  1661.       Put16(op);                         (* LEFT shift        *)
  1662.     END;
  1663.     x.wid := sz; (* resulting width of D-Register *)
  1664.     Release(y);
  1665.   END Ash2;
  1666.  
  1667.   PROCEDURE ConIndex(VAR x : Item; inc : INTEGER);
  1668.     (* called for constant index and field-offset. *)
  1669.     (*   if NOT indir :  adr-field is incremented  *)
  1670.     (*   if indir     :  off-field is incremented. *)
  1671.     VAR i : INTEGER;
  1672.   BEGIN
  1673.     WITH x DO
  1674.       IF mode < conMd THEN
  1675.         (* reference to indir, adr, off allowed. *)
  1676.         IF NOT indir THEN i := adr ELSE i := off END;
  1677.         IF (i >= 0) & (inc <= MaxInt - i)
  1678.         OR (i <  0) & (inc >= MIN(INTEGER) - i) THEN
  1679.           i := i + inc;
  1680.           IF NOT indir THEN adr := i ELSE off := i END;
  1681.         ELSE (* offset overflow *)
  1682.           LoadAdr(x); mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
  1683.           adr := inc;
  1684.         END;
  1685.       ELSE (* all other modes *)
  1686.         err(235);
  1687.       END;
  1688.     END (*WITH*);
  1689.   END ConIndex;
  1690.  
  1691.   PROCEDURE Normalize(VAR x : Item; i : INTEGER);
  1692.     (* normalize x with the low-bound i *)
  1693.     VAR op : CARDINAL; y : Item;
  1694.   BEGIN
  1695.     IF i <> 0 THEN
  1696.       (* Note : overflow-checks must be OFF for compiler! *)
  1697.       IF i > 0 THEN op := SUB ELSE op := ADD; i := ABS(i) END;
  1698.       SetconMd(y, i, x.typ);
  1699.       ADD2(op,x,y);
  1700.     END;
  1701.   END Normalize;
  1702.  
  1703.   PROCEDURE CheckHigh(VAR x, high : Item);
  1704.     (* check item associated with x to be in the   *)
  1705.     (* range indicated by [ 0.. (high) ].          *)
  1706.     (* Note : CHK treats operand and upper-bound   *)
  1707.     (*        as signed 2's complement integers!   *)
  1708.     VAR ea, op : CARDINAL; sz, hsz : WidType;
  1709.   BEGIN
  1710.     IF NOT rngchk THEN RETURN END;
  1711.     LoadD(x); (* assert x to be loaded into a D-register *)
  1712.     Isz(high,hsz); Isz(x,sz);
  1713.     IF hsz <> sz THEN LoadX(high,sz) END;
  1714.     Gea(high,ea);
  1715.     IF sz = word THEN op := CHK ELSE op := CHKL END;
  1716.     Put16(op + x.R*LS9 + ea);
  1717.     Ext(high);
  1718.     Release(high);
  1719.   END CheckHigh;
  1720.  
  1721.   PROCEDURE CheckClimit(VAR x : Item; limit : LONGINT);
  1722.     (* check item associated with x to be in the   *)
  1723.     (* range indicated by [ 0 .. limit ].          *)
  1724.     (* Note : Trap taken always if limit < 0.      *)
  1725.     (*        CHK treats operand and upper-bound   *)
  1726.     (*        as signed 2's complement integers!   *)
  1727.     VAR sz : WidType;
  1728.   BEGIN
  1729.     IF NOT rngchk THEN RETURN END;
  1730.     IF (limit < 0D) THEN err(286) END; (* invalid limit *)
  1731.     LoadD(x); (* assert x to be loaded into a D-register *)
  1732.     Isz(x,sz);
  1733.     IF sz = word THEN (* CHK *)
  1734.       Put16(CHK + x.R*LS9 + IMM);
  1735.       Put16(VAL(INTEGER, limit));
  1736.     ELSE (* CHKL *)
  1737.       Put16(CHKL + x.R*LS9 + IMM);
  1738.       Put32(limit);
  1739.     END;
  1740.   END CheckClimit;
  1741.  
  1742.   PROCEDURE CheckRange(VAR x: Item; min, max, BndAdr: INTEGER);
  1743.     (* check x in the constant range [ min .. max ]. *)
  1744.     VAR htyp : StrPtr; sz : WidType;
  1745.   BEGIN
  1746.     IF NOT rngchk THEN RETURN END;
  1747.     IF SimpleT(x) THEN Isz(x,sz);
  1748.       htyp := x.typ; (* hold original type of x *)
  1749.       LoadX(x,word);
  1750.       IF sz <= word THEN x.typ := inttyp END;
  1751.       Normalize(x, min);
  1752.       IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
  1753.         max := max - min
  1754.       ELSE
  1755.         err(286); max := 0; (* range distance too big *)
  1756.       END;
  1757.       CheckClimit(x, max);
  1758.       (* Note : overflow-checks must be OFF for compiler! *)
  1759.       (* recover original value of x : *)
  1760.       Normalize(x, - min);
  1761.       x.typ := htyp; (* recover type of x *)
  1762.     END;
  1763.   END CheckRange;
  1764.  
  1765.   PROCEDURE CheckDbltoSingle(VAR x, y : Item);
  1766.     (* range check for assignment of double-word type x *)
  1767.     (* to single-word type y (INTEGER/CARDINAL).        *)
  1768.     VAR Dn : Register;
  1769.   BEGIN
  1770.     IF NOT rngchk THEN RETURN END;
  1771.     LoadD(x);                             (* load long x *)
  1772.     GetReg(Dn,Dreg);                      (* scratch reg. *)
  1773.     IF NOT SignedT(y) THEN
  1774.        Put16(MOVEQ + Dn*LS9);             (* MOVEQ #0,Dn *)
  1775.     END;
  1776.     Put16(MOVEW + Dn*LS9 + x.R);          (* copy word part *)
  1777.     IF SignedT(y) THEN
  1778.       IF NOT SignedT(x) THEN              (* Unsigned to Signed *)
  1779.         Put16(BMI + 6);                   (* exclude values < 0 *)
  1780.       END;
  1781.       Put16(EXTL + Dn);                   (* EXT.L Dn    *)
  1782.     END;
  1783.     Put16(CMP + x.R*LS9 + long*LS6 + Dn); (* CMP.L  Dn,x.R *)
  1784.     Put16(BEQ + 4);                       (* BEQ.S  4      *)
  1785.     Put16(CHK + Dn*LS9 + IMM);            (* CHK    #-1,Dn *)
  1786.     Put16(-1); (* trap always *)
  1787.     ReleaseReg(Dn);
  1788.   END CheckDbltoSingle;
  1789.  
  1790.   PROCEDURE VarIndex(VAR x, y : Item; elsize : INTEGER);
  1791.     (* generate x with a variable index y and elementsize elsize. *)
  1792.     CONST quad = 3;
  1793.     VAR elsz : Item; scale, pw2 : CARDINAL;
  1794.   BEGIN
  1795.     SetconMd(elsz, elsize, y.typ);
  1796.     IF elsize = 1 THEN scale := byte
  1797.     ELSIF elsize = 2 THEN scale := word
  1798.     ELSIF elsize = 4 THEN scale := long
  1799.     ELSIF elsize = 8 THEN scale := quad
  1800.     ELSE
  1801.       IF ~Power2(elsz,pw2) & (y.typ = dbltyp) THEN
  1802.         y.typ := inttyp; (* force 16*16Bit MULS.W *)
  1803.         SetconMd(elsz, elsize, y.typ);
  1804.       END;
  1805.       MUL2(y,elsz,FALSE); (* inhibit overflow-checks *)
  1806.       scale := byte;
  1807.     END;
  1808.     LoadAdr(x);
  1809.     WITH x DO
  1810.       (* transform 'AregMd' to 'RidxMd' *)
  1811.       mode := RidxMd;  indir := FALSE;
  1812.       adr  := 0;       off   := 0;
  1813.       RX   := y.R;     wid   := y.wid;
  1814.       scl  := scale;
  1815.     END (*WITH*);
  1816.   END VarIndex;
  1817.  
  1818.   PROCEDURE GetHigh(VAR x : Item);
  1819.     (* get high-index of dynamic array parameter : *)
  1820.     (*                                             *)
  1821.     (* Caution :  x.typ IS changed !               *)
  1822.     (* -------                                     *)
  1823.   BEGIN
  1824.     WITH x DO
  1825.       IF mode < conMd THEN
  1826.         (* reference to indir, adr, off allowed. *)
  1827.         indir := FALSE;    off := 0;
  1828.         adr   := adr + 4;  typ := hightyp;
  1829.       ELSE err(240)
  1830.       END;
  1831.     END (*WITH*);
  1832.   END GetHigh;
  1833.  
  1834.   PROCEDURE PreLoad(VAR op : Symbol; VAR x , y : Item);
  1835.     (* preload x and/or y for GenOp.     *)
  1836.     (* Note : No exchange of operands    *)
  1837.     (* ----   for real types on purpose! *)
  1838.     VAR z : Item;
  1839.   BEGIN (* do nothing if x is not 'loadable' *)
  1840.     IF NOT(SimpleT(x) & SimpleT(y)) THEN RETURN END;
  1841.     IF (op = times) OR (op = plus) THEN
  1842.       (* symmetric operators : *)
  1843.       IF x.mode # DregMd THEN
  1844.         IF (y.mode = DregMd) & (y.R IN Rpool) THEN
  1845.           z := x; x := y; y := z;
  1846.         ELSE
  1847.           IF (x.mode = conMd) & (y.mode <= stkMd) THEN
  1848.             z := x; x := y; y := z;
  1849.           END;
  1850.           LoadD(x);
  1851.         END;
  1852.       (* else x already loaded *)
  1853.       END;
  1854.     ELSIF (op = div) OR (op = mod) THEN
  1855.       (* a-symmetric operators : *)
  1856.       (* 32bits / 16bits for DIVS/DIVU ! *)
  1857.       LoadD(x);
  1858.     ELSIF (op = slash) OR (op = minus) OR (op = rem) THEN
  1859.       (* a-symmetric operators : *)
  1860.       LoadD(x);
  1861.     ELSIF (op >= eql) & (op <= geq) THEN
  1862.       (* relational operators : *)
  1863.       IF x.mode = conMd THEN
  1864.         (* y.mode # conMd ! *)
  1865.         z := x; x := y; y := z;
  1866.         IF    op = lss THEN op := gtr
  1867.         ELSIF op = leq THEN op := geq
  1868.         ELSIF op = gtr THEN op := lss
  1869.         ELSIF op = geq THEN op := leq
  1870.         ELSE (* op := op *)
  1871.         END;
  1872.       END;
  1873.     ELSE (* nothing for all other ops *)
  1874.     END;
  1875.   END PreLoad;
  1876.  
  1877.   PROCEDURE DynArray  (VAR x, y : Item);
  1878.     (* generate descriptor for dynamic array parameters : *)
  1879.     (*                                                    *)
  1880.     (* Caution :    guarantee HIGH to be in the range     *)
  1881.     (* -------      0   <=   HIGH   <=   MaxInt.          *)
  1882.     (*                                                    *)
  1883.     CONST ByteSize = 1;
  1884.     VAR high, onstack, e : Item; s : StrPtr;
  1885.         i, elsize : INTEGER; dynbyte   : BOOLEAN;
  1886.   BEGIN
  1887.     dynbyte := (x.typ^.ElemTyp = bytetyp);
  1888.     IF (y.typ^.form = Array) THEN
  1889.       elsize := y.typ^.ElemTyp^.size;
  1890.       IF y.typ^.dyn THEN (* copy existing descriptor *)
  1891.         high := y; GetHigh(high);
  1892.         IF dynbyte & (elsize <> ByteSize) THEN
  1893.           LoadD(high);
  1894.           Inc1(high);         (* enable overflow-check *)
  1895.           SetconMd(e, elsize, high.typ);
  1896.           MUL2(high,e,TRUE);
  1897.           Op1(DEC1,high);     (* disable overflow-check *)
  1898.           IF ovflchk THEN CheckClimit(high, MaxInt - 1) END;
  1899.         END;
  1900.       ELSE (* generate new descriptor *)
  1901.         IF NOT dynbyte THEN
  1902.           s := y.typ^.IndexTyp; i := 0;
  1903.           WITH s^ DO
  1904.             IF form = Range THEN
  1905.               IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
  1906.                 i := max - min
  1907.               ELSE
  1908.                 err(286); (* range distance too big *)
  1909.               END;
  1910.             END (*Range*);
  1911.           END (*WITH*);
  1912.         ELSE
  1913.           WITH y.typ^ DO
  1914.             IF (form = Array) & (IndexTyp^.form = Range) & (elsize = 1) THEN
  1915.               i := IndexTyp^.max - IndexTyp^.min;
  1916.             ELSE
  1917.               i := size; IF i > 0 THEN DEC(i) END;
  1918.             END;
  1919.           END;
  1920.         END;
  1921.         SetconMd(high, i, hightyp);
  1922.       END;
  1923.     ELSIF (y.typ^.form = String) THEN
  1924.       i := y.val.D1; IF i > 0 THEN DEC(i) END;
  1925.       SetconMd(high, i, hightyp);
  1926.     ELSE
  1927.       i := y.typ^.size; IF i > 0 THEN DEC(i) END;
  1928.       SetconMd(high, i, hightyp);
  1929.       IF y.mode >= conMd THEN err(231) END;
  1930.     END;
  1931.     SetstkMd(onstack, hightyp);
  1932.     Move(high,onstack);
  1933.     MoveAdr(y,onstack);
  1934.     Release(high);
  1935.     Release(y);
  1936.   END DynArray;
  1937.  
  1938.   PROCEDURE CopyDynArray(a, s : INTEGER);
  1939.     (* descriptor at a(MP), element-size is s :  *)
  1940.     (* copy (high+1)*s Bytes from [a(MP)] on top *)
  1941.     (* of stack and update descriptor address.   *)
  1942.     VAR Dn, An, Am : Register; op, src, dst : CARDINAL; x, e : Item;
  1943.   BEGIN
  1944.     SetlocMd(x, a+4, hightyp);
  1945.     LoadD(x); Dn := x.R;
  1946.     (* Caution : value of HIGH must be in positive INTEGER range, *)
  1947.     (* -------   even if HIGH is hold in a longword (LONGINT) !   *)
  1948.     (*           this is essential for the code generation below. *)
  1949.     Inc1(x);         (* (high + 1)     = nr. of elements *)
  1950.     IF (s > 1) THEN  (* (high + 1) * s = nr. of bytes to copy *)
  1951.       SetconMd(e, s, x.typ);
  1952.       MUL2(x,e,TRUE);
  1953.     END;
  1954.     IF ovflchk THEN CheckClimit(x, MaxInt - 1) END;
  1955.     IF ODD(s) THEN
  1956.       (* Note : Dn will never overflow at the INC below ! *)
  1957.       Put16(BTST + LS11 - LS8 + Dn);          (* total nr. of bytes   *)
  1958.       Put16(0);                               (* must be even         *)
  1959.       Put16(BEQ + 2);                         (* skip if already even *)
  1960.       Put16(INC1 + word*LS6 + Dn);            (* if odd then + 1      *)
  1961.     END;
  1962.     GetReg(An,Areg); GetReg(Am,Areg);
  1963.     src := An MOD 8; dst := Am MOD 8;
  1964.     Put16(SUBAL-LS8 + SP*LS9 + Dn);           (* SUBA.W   Dn.W,SP     *)
  1965.     Put16(MOVEAL + src*LS9 + AOFF + MP);      (* MOVEA.L  a(MP),An    *)
  1966.     Put16(a);
  1967.     Put16(MOVEL + Iea(AOFF+MP)*LS6 + ADIR+SP);(* MOVE.L   SP,a(MP)    *)
  1968.     Put16(a);                                 (* update descriptor    *)
  1969.     Put16(MOVEAL + dst*LS9 + ADIR + SP);      (* MOVEA.L  SP,Am       *)
  1970.     src := AINC + src; dst := AINC + dst;
  1971.     Put16(ASR + LS9 + word*LS6 + Dn);         (* Dn := Dn DIV 2       *)
  1972.     Put16(DEC1 + word*LS6 + Dn);              (* loop count in Dn     *)
  1973.     Put16(MOVEW + Iea(dst)*LS6 + src);     (* L: MOVE.W  (An)+,(Am)+  *)
  1974.     Put16(DBRA + Dn);                      (*    DBRA     Dn.W,L      *)
  1975.     Put16(177774B);
  1976.     Release(x);
  1977.     ReleaseReg(An);
  1978.     ReleaseReg(Am);
  1979.   END CopyDynArray;
  1980.  
  1981.   PROCEDURE EnterCase (VAR x : Item; base, lo, hi : INTEGER);
  1982.     (*  enter case-statement processor *)
  1983.     VAR m, n, z : Item; An : Register; xt : StrPtr;
  1984.   BEGIN
  1985.     WITH z DO
  1986.       (* transform z to 'prgMd' *)
  1987.       typ := inttyp; mode := prgMd; where := base;
  1988.     END (*WITH z*);
  1989.     xt := x.typ; (* hold original type of x *)
  1990.     LoadX(x,word); x.typ := inttyp;
  1991.     LoadAdr(z); (* z.mode := RindMd; *)
  1992.     An := z.R MOD 8;
  1993.     IF (lo = 1) & (hi = 0) THEN (* if empty case statement *)
  1994.       Put16(JSR + AIDR + An)
  1995.     ELSE (* not-empty case *)
  1996.       SetconMd(m, lo, x.typ);
  1997.       ADD2(SUB,x,m);
  1998.       SetconMd(n, hi - lo, x.typ);
  1999.       Cmp2(x,n);
  2000.       Put16(BLS + 2);
  2001.       Put16(MOVEQ + x.R*LS9 + 377B); (* MOVEQ #-1,R *)
  2002.       SetconMd(m, 1D, inttyp);
  2003.       SHI2(ASL,x,m);
  2004.       Put16(MOVEW + x.R*LS9 + AIDX + An);
  2005.       IF x.wid = word THEN Put16(x.R*LS12) ELSE Put16(x.R*LS12 + LS11) END;
  2006.       Put16(JSR + AIDX + An);
  2007.       Put16(x.R*LS12)
  2008.     END;
  2009.     Release(z);
  2010.     Release(x);
  2011.     x.typ := xt; (* restore original type of x *)
  2012.   END EnterCase;
  2013.  
  2014.   PROCEDURE ExitCase;
  2015.     (*  leave case-statement *)
  2016.   BEGIN
  2017.     Put16(RTS);
  2018.   END ExitCase;
  2019.  
  2020.   PROCEDURE Link      (VAR l : CARDINAL; lev : CARDINAL);
  2021.     (* generate entry-code for procedure at level lev *)
  2022.   BEGIN
  2023.     IF lev = 0 THEN
  2024.       (* global procedure *)
  2025.       Put16(PUSHSB);                     (* MOVE.L  SB,-(SP)   *)
  2026.       Put16(MOVEAL + SB*LS9 + PREL);     (* MOVEA.L -d(PC),SB  *)
  2027.       Put16(-VAL(INTEGER,pc));           (* points to relative address 0! *)
  2028.     END;
  2029.     (* global and local procedure *)
  2030.     Put16(LINK);                         (* LINK     MP,#local-data-size  *)
  2031.     l := pc;
  2032.     Put16(0);
  2033.   END Link;
  2034.  
  2035.   PROCEDURE Unlink    (parSize : INTEGER; lev : CARDINAL);
  2036.     (* generate exit-code for procedure at level lev *)
  2037.   BEGIN
  2038.     Put16(UNLK);                         (* UNLK MP          *)
  2039.     IF lev = 0 THEN
  2040.       (* global procedure *)
  2041.       Put16(POPSB);                      (* MOVEA.L (SP)+,SB *)
  2042.     ELSE
  2043.      (* local procedure : include SL *)
  2044.      (* in the parameter size.       *)
  2045.       parSize := parSize + 4;
  2046.     END;
  2047.     IF parSize = 0 THEN Put16(RTS)       (* RTS              *)
  2048.     ELSE                                 (* or               *)
  2049.       Put16(RTD);                        (* RTD #parSize     *)
  2050.       Put16(parSize);
  2051.     END;
  2052.   END Unlink;
  2053.  
  2054.   PROCEDURE CallInt   (proc : ObjPtr);
  2055.     (* call of local procedure *)
  2056.   BEGIN
  2057.     WITH proc^ DO
  2058.       IF pd <> NIL THEN
  2059.         Put16(BSR);
  2060.         Put16(pd^.adr - VAL(INTEGER,pc));
  2061.       END (*pd*);
  2062.     END (*WITH*);
  2063.   END CallInt;
  2064.  
  2065.   PROCEDURE CallExt   (proc : ObjPtr);
  2066.     (* call of external procedure *)
  2067.   BEGIN
  2068.     WITH proc^ DO
  2069.       IF pd <> NIL THEN ExternalCall(pmod, pd^.num) END;
  2070.     END (*WITH*);
  2071.   END CallExt;
  2072.  
  2073.   PROCEDURE CallInd   (VAR x : Item);
  2074.     (* call of procedure variable *)
  2075.     VAR ea : CARDINAL;
  2076.   BEGIN
  2077.     LoadP(x); x.mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
  2078.     Gea(x,ea);
  2079.     Put16(JSR + ea);
  2080.     Ext(x);
  2081.     Release(x);
  2082.   END CallInd;
  2083.  
  2084.   PROCEDURE ExitModule;
  2085.   BEGIN
  2086.     Unlink(0,0);
  2087.   END ExitModule;
  2088.  
  2089.   PROCEDURE EnterModule;
  2090.     VAR dummy : CARDINAL;
  2091.   BEGIN
  2092.     (* main module entry code : *)
  2093.     Link(dummy, 0);
  2094.     Put16(BSET + LS11 - LS8 + AOFF + SB); (* BSET     #0,-2(SB) *)
  2095.     Put16(0);
  2096.     Put16(-2);
  2097.     Put16(BEQ + 6);                       (* BEQ      +6        *)
  2098.     Unlink(0,0);                          (* exactly 6 Bytes!   *)
  2099.   END EnterModule;
  2100.  
  2101.   PROCEDURE InitModule(m : CARDINAL);
  2102.   BEGIN
  2103.     ExternalCall(m, 0);
  2104.   END InitModule;
  2105.  
  2106.  
  2107.   (* The Floating-Point code generator : *)
  2108.  
  2109.   PROCEDURE fmt(VAR x : Item) : CARDINAL;
  2110.     (* source specifier for <ea> : left shift by 10 is *)
  2111.     (* already included in the return value.           *)
  2112.     (* Note : do NOT allow for unsigned types !        *)
  2113.     VAR c : CARDINAL; ftyp : StrPtr;
  2114.   BEGIN
  2115.     ftyp := x.typ;
  2116.     WHILE ftyp^.form = Range DO ftyp := ftyp^.RBaseTyp END;
  2117.     IF    ftyp = realtyp THEN c := 1 (* S *)
  2118.     ELSIF ftyp = lrltyp  THEN c := 5 (* D *)
  2119.     ELSIF ftyp = dbltyp  THEN c := 0 (* L *)
  2120.     ELSIF ftyp = inttyp  THEN c := 4 (* W *)
  2121.     ELSIF (ftyp = cardtyp) & (x.mode = conMd) &
  2122.           (x.val.C <= MaxInt) THEN c := 4 (* W *)
  2123.     ELSE err(241); c := 0;
  2124.     END;
  2125.     RETURN c*LS10
  2126.   END fmt;
  2127.  
  2128.   PROCEDURE FMove(VAR x, y : Item);
  2129.     (* floating move x to y. *)
  2130.     VAR Fn : Register; ea, sz : CARDINAL;
  2131.   BEGIN
  2132.     sz := VAL(CARDINAL, y.typ^.size);
  2133.     IF y.mode = fltMd THEN
  2134.       (* load to floating-point register : *)
  2135.       Fn := y.FR;
  2136.       IF x.mode = fltMd THEN (* FMOVE.X  Fm,Fn *)
  2137.         IF x.FR <> Fn THEN
  2138.           Put16(FGEN);
  2139.           Put16(FtoF + x.FR*LS10 + Fn*LS7);
  2140.         END;
  2141.       ELSIF x.mode <= DregMd THEN (* FMOVE.<fmt> <ea>,Fn *)
  2142.         IF x.mode = AregMd THEN LoadD(x) END;
  2143.         Gea(x,ea);
  2144.         Put16(FGEN + ea);
  2145.         Put16(EAtoF + fmt(x) + Fn*LS7);
  2146.         Ext(x);
  2147.       ELSE err(245)
  2148.       END;
  2149.     ELSIF x.mode = fltMd THEN
  2150.       (* store from floating-point register : *)
  2151.       Fn := x.FR;
  2152.       IF y.mode <= DregMd THEN (* FMOVE.<fmt> Fn,<ea> *)
  2153.         IF (y.mode = AregMd) OR (y.mode = conMd) THEN err(285) END;
  2154.         IF (y.mode = stkMd) THEN ea := 47B (* gives -(SP) *)
  2155.         ELSE Gea(y,ea) END;
  2156.         Put16(FGEN + ea);
  2157.         Put16(FtoEA + fmt(y) + Fn*LS7);
  2158.         Ext(y);
  2159.         IF y.mode = DregMd THEN y.wid := long;
  2160.           (* equivalent to a LoadD-operation :   *)
  2161.           (* set the width of the result stored. *)
  2162.           IF sz > 4 THEN err(285)
  2163.           ELSE y.wid := sz DIV 2 END;
  2164.         END;
  2165.       ELSE err(245)
  2166.       END;
  2167.     ELSIF x.typ = y.typ THEN
  2168.       (* move identical types from <ea> to <ea> : *)
  2169.       IF sz <= 4 THEN Move(x,y)
  2170.       ELSIF (sz = 8) & (x.mode <= stkMd) & (y.mode <= stkMd) THEN MoveQuad(x,y)
  2171.       ELSE err(245)
  2172.       END;
  2173.     ELSE
  2174.       (* move NON-identical types : *)
  2175.       LoadF(x);   (* load x into floating point reg. *)
  2176.       FMove(x,y); (* re-call *)
  2177.     END;
  2178.   END FMove;
  2179.  
  2180.   PROCEDURE LoadF(VAR x : Item);
  2181.     (* load x into a floating-point register : *)
  2182.     VAR Fn : Register; y : Item;
  2183.   BEGIN
  2184.     IF x.mode <= DregMd THEN
  2185.       GetFReg(Fn);
  2186.       SetfltMd(y, Fn, x.typ);
  2187.       FMove(x,y);
  2188.       Release(x);
  2189.       x := y;
  2190.     ELSIF x.mode <> fltMd THEN
  2191.       err(241); Release(x);
  2192.       SetfltMd(x, F0, x.typ);
  2193.     END;
  2194.   END LoadF;
  2195.  
  2196.   PROCEDURE FOp1(op : CARDINAL; VAR x : Item);
  2197.     VAR Fn : Register; ea : CARDINAL;
  2198.   BEGIN
  2199.     IF x.mode = fltMd THEN
  2200.       (* Fop.X   FPn *)
  2201.       IF op <> FTST THEN Fn := x.FR ELSE Fn := 0 END;
  2202.       Put16(FGEN);
  2203.       Put16(FtoF + x.FR*LS10 + Fn*LS7 + op);
  2204.       (* the same source and dest. register! *)
  2205.     ELSE
  2206.       (* Fop.<fmt>  <ea>,FPn *)
  2207.       IF op <> FTST THEN GetFReg(Fn) ELSE Fn := 0 END;
  2208.       IF x.mode = AregMd THEN LoadD(x) END;
  2209.       Gea(x,ea);
  2210.       Put16(FGEN + ea);
  2211.       Put16(EAtoF + fmt(x) + Fn*LS7 + op);
  2212.       Ext(x);
  2213.       Release(x); (* free the old registers! *)
  2214.       (* resulting mode is 'fltMd' : *)
  2215.       x.mode := fltMd; x.FR := Fn;
  2216.     END;
  2217.   END FOp1;
  2218.  
  2219.   PROCEDURE FOp2(op : CARDINAL; VAR x, y : Item);
  2220.     VAR ea : CARDINAL;
  2221.   BEGIN
  2222.     LoadF(x); (* resulting mode is 'fltMd' *)
  2223.     IF y.mode = fltMd THEN
  2224.       (* Fop.X   FPm,FPn *)
  2225.       Put16(FGEN);
  2226.       Put16(FtoF + y.FR*LS10 + x.FR*LS7 + op);
  2227.     ELSE
  2228.       (* Fop.<fmt>  <ea>,FPn *)
  2229.       IF x.mode = AregMd THEN LoadD(x) END;
  2230.       Gea(y,ea);
  2231.       Put16(FGEN + ea);
  2232.       Put16(EAtoF + fmt(y) + x.FR*LS7 + op);
  2233.       Ext(y);
  2234.     END;
  2235.     Release(y); (* free y's registers! *)
  2236.   END FOp2;
  2237.  
  2238.   PROCEDURE FMonad(op : FMonadic; VAR x : Item);
  2239.     (* interface to the MC68040 monadic operators : *)
  2240.     VAR cd : CARDINAL; Dn : Register; y : Item;
  2241.   BEGIN
  2242.     cd := 200B; (* indicates NO FOp1-call *)
  2243.     CASE op OF
  2244.     | Abs :           cd := FABS;
  2245.     | NonStand :      cd := FNEG;
  2246.     | Sqrt :          cd := FSQRT;
  2247.     | Float :         cd := FMOVE; (* INC(cd, 64); *)                  (* RPsbI *)
  2248.     | FloatD :        cd := FMOVE; (* INC(cd, 68); *)                  (* RPsbI *)
  2249.     | Long :          cd := FMOVE; (* INC(cd, 68); *)                  (* RPsbI *)
  2250.     | Short :         cd := FMOVE; (* INC(cd, 64); *)                  (* RPsbI *)
  2251.     | Trunc, TruncD,
  2252.       Entier, Round : LoadF(x);
  2253.                       Put16(FGEN + D1); (* save FPCR to D1 *)
  2254.                       Put16(CRtoEA);
  2255.                       Put16(MOVEL + D1);
  2256.                       Put16(ANDI + D0); Put16(317B);
  2257.                       Put16(ORI + D0);
  2258.                       IF op = Round THEN Put16(0)
  2259.                       ELSIF op = Entier THEN Put16(40B)
  2260.                       ELSE Put16(20B) END;
  2261.                       Put16(FGEN + D0); (* modify FPCR *)
  2262.                       Put16(EAtoCR);
  2263.                       GetReg(Dn,Dreg);
  2264.                       IF op = Trunc THEN SetregMd(y,Dn,inttyp) 
  2265.                       ELSE SetregMd(y,Dn,dbltyp) END;
  2266.                       FMove(x,y);       (* FMOVE FPm,Dn *)
  2267.                       Release(x);
  2268.                       x := y;
  2269.                       Put16(FGEN + D1); (* restore D1 to FPCR *)
  2270.                       Put16(EAtoCR);
  2271.     ELSE              err(200);
  2272.     END (*CASE*);
  2273.     IF cd < 200B THEN
  2274.       (* RPsbI : Rounding-Precision specified by Instruction :
  2275.       IF (cd = FABS) OR (cd = FNEG) OR (cd = FSQRT) THEN               (* RPsbI *)
  2276.         IF (cd = FSQRT) THEN cd := 1 END;                              (* RPsbI *)
  2277.         IF (x.typ = realtyp) THEN INC(cd, 64) ELSE INC(cd, 68) END;    (* RPsbI *)
  2278.       END;                                                             (* RPsbI *)
  2279.       *)
  2280.       FOp1(cd,x);
  2281.     END;
  2282.   END FMonad;
  2283.  
  2284.   PROCEDURE FDyad(op : FDyadic; VAR x, y : Item);
  2285.     (* interface to the MC68040 dyadic operators : *)
  2286.     VAR cd : CARDINAL;
  2287.   BEGIN
  2288.     cd := 200B; (* indicates NO FOp2-call *)
  2289.     CASE op OF
  2290.     | plus  :         cd := FADD;
  2291.     | minus :         cd := FSUB;
  2292.     | times :         cd := FMUL;
  2293.     | slash :         cd := FDIV; IF ZeroVal(y) THEN err(205) END;
  2294.     | eql .. geq :    cd := FCMP; IF ZeroVal(y) THEN cd := FTST END;
  2295.     ELSE              err(200);
  2296.     END (*CASE*);
  2297.     IF cd = FTST THEN FOp1(FTST,x)
  2298.     ELSIF cd < 200B THEN
  2299.       (* RPsbI : Rounding-Precision specified by Instruction :
  2300.       IF (cd = FADD) OR (cd = FSUB) OR (cd = FMUL) OR (cd = FDIV) THEN (* RPsbI *)
  2301.         IF (x.typ = realtyp) THEN INC(cd, 64) ELSE INC(cd, 68) END;    (* RPsbI *)
  2302.       END;                                                             (* RPsbI *)
  2303.       *)
  2304.       FOp2(cd,x,y);
  2305.     END;
  2306.     Release(y);
  2307.   END FDyad;
  2308.  
  2309.  
  2310. END M2HM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  2311.